symantic/Language/Symantic/Typing/Grammar.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE PolyKinds #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 {-# LANGUAGE UndecidableInstances #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Language.Symantic.Typing.Grammar where
   7
   8 import Control.Applicative (Applicative(..))
   9 import Data.List (foldl1')
  10 import Data.Map.Strict (Map)
  11 import Data.Maybe (fromMaybe)
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.String (IsString(..))
  14 import Prelude hiding (any)
  15 import qualified Data.Char as Char
  16 import qualified Data.Map.Strict as Map
  17 import qualified Data.Text as Text
  18
  19 import Language.Symantic.Grammar as G
  20 import Language.Symantic.Typing.Kind
  21 import Language.Symantic.Typing.Variable
  22 import Language.Symantic.Typing.List
  23 import Language.Symantic.Typing.Module
  24 import Language.Symantic.Typing.Type
  25
  26 -- * Type 'AST_Type'
  27 -- | /Abstract Syntax Tree/ of 'Token_Type'.
  28 type AST_Type src = BinTree (Token_Type src)
  29
  30 -- ** Type 'Token_Type'
  31 data Token_Type src
  32  =   Token_Type_Const (TypeTLen src)
  33  |   Token_Type_Var   (At src NameVar)
  34  -- deriving (Eq, Show)
  35 instance Source src => Eq (Token_Type src) where
  36         Token_Type_Const (TypeTLen x) == Token_Type_Const (TypeTLen y) = x LenZ == y LenZ
  37         Token_Type_Var (At _ x) == Token_Type_Var (At _ y) = x == y
  38         _ == _ = False
  39 instance (Source src, Show (TypeT src '[])) => Show (Token_Type src) where
  40         showsPrec p (Token_Type_Const x) =
  41                 showParen (p >= 10) $
  42                 showString "Token_Type_Const" .
  43                 showChar ' ' . showsPrec 10 x
  44         showsPrec p (Token_Type_Var (At _ x)) =
  45                 showParen (p >= 10) $
  46                 showString "Token_Type_Var" .
  47                 showChar ' ' . showsPrec 10 x
  48
  49 -- * Type 'ModulesTy'
  50 type ModulesTy src = Map (Mod NameTy) (TypeTLen src)
  51
  52 -- ** Type 'TypeTLen'
  53 -- | Like 'TypeT', but needing a @(@'Len'@ vs)@ to be built.
  54 --
  55 -- Useful to build a 'ModulesTy' which can be used
  56 -- whatever will be the @(@'Len'@ vs)@ given to 'readTyVars'.
  57 newtype TypeTLen src = TypeTLen (forall vs. Len vs -> TypeT src vs)
  58 instance Source src => Eq (TypeTLen src) where
  59         TypeTLen x == TypeTLen y = x LenZ == y LenZ
  60 instance (Source src, Show (TypeT src '[])) => Show (TypeTLen src) where
  61         showsPrec p (TypeTLen t) = showsPrec p $ t LenZ
  62
  63 typeTLen ::
  64  forall c src.
  65  Source src =>
  66  Constable c =>
  67  KindInjP (Ty_of_Type (K c)) =>
  68  K c ~ Type_of_Ty (Ty_of_Type (K c)) =>
  69  src ->
  70  TypeTLen src
  71 typeTLen src =
  72         TypeTLen $ \len -> TypeT $
  73                 TyConst src len $
  74                 constKiInj @(K c) @c $
  75                 kindInjP @(Ty_of_Type (K c)) noSource
  76
  77 -- ** Class 'ModulesTyInj'
  78 -- | Derive a 'ModulesTy' from the given type-level list
  79 -- of 'Proxy'-fied /type constants/.
  80 class ModulesTyInj ts where
  81         modulesTyInj :: Source src => ModulesTy src
  82 instance ModulesTyInj '[] where
  83         modulesTyInj = Map.empty
  84 instance
  85  ( KindInjP (Ty_of_Type (K c))
  86  , K c ~ Type_of_Ty (Ty_of_Type (K c))
  87  , Constable c
  88  , ModulesTyInj ts
  89  ) => ModulesTyInj (Proxy c ': ts) where
  90         modulesTyInj =
  91                 Map.insert
  92                  (nameTyOf $ Proxy @c)
  93                  (typeTLen @c noSource) $
  94                 modulesTyInj @ts
  95
  96
  97 -- * Class 'Gram_Mod'
  98 class
  99  ( Gram_Terminal g
 100  , Gram_Rule g
 101  , Gram_Alt g
 102  , Gram_Try g
 103  , Gram_App g
 104  , Gram_AltApp g
 105  , Gram_RegL g
 106  , Gram_CF g
 107  , Gram_Comment g
 108  , Gram_Op g
 109  ) => Gram_Mod g where
 110         g_PathMod :: CF g PathMod
 111         g_PathMod = rule "PathMod" $
 112                 infixrG
 113                  (pure <$> g_NameMod)
 114                  (op <$ char '.')
 115                 where op = (<>)
 116         g_NameMod :: CF g NameMod
 117         g_NameMod = rule "NameMod" $
 118                 NameMod . Text.pack <$> identG
 119                 where
 120                 identG = (:) <$> headG <*> many (cfOf tailG)
 121                 headG = unicat $ Unicat Char.UppercaseLetter
 122                 tailG :: Terminal g Char
 123                 tailG =
 124                         unicat Unicat_Letter <+>
 125                         unicat Unicat_Number
 126
 127 deriving instance Gram_Mod g => Gram_Mod (CF g)
 128 instance Gram_Mod EBNF
 129 instance Gram_Mod RuleEBNF
 130
 131 -- * Class 'Gram_Type_Name'
 132 class
 133  ( Gram_Terminal g
 134  , Gram_Rule g
 135  , Gram_Alt g
 136  , Gram_Try g
 137  , Gram_App g
 138  , Gram_AltApp g
 139  , Gram_RegL g
 140  , Gram_CF g
 141  , Gram_Comment g
 142  , Gram_Op g
 143  , Gram_Mod g
 144  ) => Gram_Type_Name g where
 145         g_ModNameTy :: CF g (Mod NameTy)
 146         g_ModNameTy = rule "ModNameTy" $
 147                 lexeme $
 148                         g_ModNameTyId <+>
 149                         parens g_ModNameTyOp
 150
 151         g_ModNameTyId :: CF g (Mod NameTy)
 152         g_ModNameTyId = rule "ModNameTyId" $
 153                 Mod
 154                  <$> option [] (try $ g_PathMod <* char '.')
 155                  <*> g_NameTyId
 156         g_NameTyId :: CF g NameTy
 157         g_NameTyId = rule "NameTyId" $
 158                 NameTy . Text.pack <$> identTyG
 159                 where
 160                 identTyG = (:) <$> headTyG <*> many (cfOf tailTyG)
 161                 headTyG = unicat $ Unicat Char.UppercaseLetter
 162                 tailTyG :: Terminal g Char
 163                 tailTyG =
 164                         unicat Unicat_Letter <+>
 165                         unicat Unicat_Number
 166
 167         g_ModNameTyOp :: CF g (Mod NameTy)
 168         g_ModNameTyOp = rule "ModNameTyOp" $
 169                 Mod
 170                  <$> option [] (try $ g_PathMod <* char '.')
 171                  <*> g_NameTyOp
 172         g_NameTyOp :: CF g NameTy
 173         g_NameTyOp = rule "NameTyOp" $
 174                 NameTy . Text.pack <$> many (cfOf okG)
 175                 where
 176                 okG :: Terminal g Char
 177                 okG = choice (unicat <$>
 178                          [ Unicat_Symbol
 179                          , Unicat_Punctuation
 180                          , Unicat_Mark
 181                          ]) `but` koG
 182                 koG = choice (char <$> ['(', ')', '`', '\'', '[', ']'])
 183
 184 deriving instance Gram_Type_Name g => Gram_Type_Name (CF g)
 185 instance Gram_Type_Name EBNF
 186 instance Gram_Type_Name RuleEBNF
 187
 188 -- * Class 'Gram_Type'
 189 -- | Read an 'AST_Type' from a textual source.
 190 class
 191  ( Gram_Source src g
 192  , Gram_Terminal g
 193  , Gram_Rule g
 194  , Gram_Alt g
 195  , Gram_Try g
 196  , Gram_App g
 197  , Gram_AltApp g
 198  , Gram_CF g
 199  , Gram_Comment g
 200  , Gram_Op g
 201  , Gram_Type_Name g
 202  , Gram_Error (Error_Type src) g
 203  , Gram_State (Imports NameTy, ModulesTy src) g
 204  , Constable (->)
 205  , Constable []
 206  , Constable (,)
 207  ) => Gram_Type src g where
 208         g_type :: CF g (AST_Type src)
 209         g_type = rule "type" $ g_type_fun
 210         g_type_fun :: CF g (AST_Type src)
 211         g_type_fun = rule "type_fun" $
 212                 infixrG g_type_list (source $ op <$ symbol "->")
 213                 where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ typeTLen @(->) src)
 214         -- TODO: maybe not harcoding g_type_list and g_type_tuple2
 215         g_type_list :: CF g (AST_Type src)
 216         g_type_list = rule "type_list" $
 217                 source $ inside mk
 218                  (symbol "[") (optional g_type) (symbol "]")
 219                  (const <$> g_type_tuple2)
 220                 where
 221                 mk Nothing  src = tok src
 222                 mk (Just a) src = BinTree2 (tok src) a
 223                 tok = BinTree0 . Token_Type_Const . typeTLen @[]
 224         g_type_tuple2 :: CF g (AST_Type src)
 225         g_type_tuple2 = rule "type_tuple2" $
 226                 try (parens (infixrG (g_type) (source $ op <$ symbol ","))) <+> (g_type_app)
 227                 where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ typeTLen @(,) src)
 228         g_type_app :: CF g (AST_Type src)
 229         g_type_app = rule "type_app" $
 230                 foldl1' BinTree2 <$> some (g_type_atom)
 231         g_type_atom :: CF g (AST_Type src)
 232         g_type_atom = rule "type_atom" $
 233                 try (parens g_type) <+>
 234                 g_type_name_const <+>
 235                 g_type_name_var
 236         g_type_name_const :: CF g (AST_Type src)
 237         g_type_name_const = rule "type_name_const" $
 238                 lexeme $ catch $ source $ getBefore $
 239                 (\n (impsTy, modsTy) src -> BinTree0 . Token_Type_Const <$> readTyName impsTy modsTy src n)
 240                  <$> g_ModNameTy
 241         g_type_name_var :: CF g (AST_Type src)
 242         g_type_name_var = rule "type_name_var" $
 243                 lexeme $ source $
 244                 (\n ns src -> BinTree0 $ Token_Type_Var $ At src $ fromString $ n:ns)
 245                  <$> unicat (Unicat Char.LowercaseLetter)
 246                  <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
 247
 248 deriving instance Gram_Type src g => Gram_Type src (CF g)
 249 instance
 250  ( Gram_Source src EBNF
 251  , Constable (->)
 252  , Constable (,)
 253  , Constable []
 254  ) => Gram_Type src EBNF
 255 instance
 256  ( Gram_Source src RuleEBNF
 257  , Constable (->)
 258  , Constable (,)
 259  , Constable []
 260  ) => Gram_Type src RuleEBNF
 261
 262 -- | Lookup a 'TyConst' or 'Type' synonym
 263 -- associated with given 'NameTy' in given 'ModulesTy',
 264 -- building it for a @vs@ of given 'Len'.
 265 readTyName ::
 266  Source src =>
 267  Imports NameTy ->
 268  ModulesTy src -> src -> Mod NameTy ->
 269  Either (Error_Type src) (TypeTLen src)
 270 readTyName is ms src name@(m `Mod` n) =
 271         let m' = fromMaybe m $ lookupImports FixyInfix name is in
 272         case Map.lookup (m' `Mod` n) ms of
 273          Just t -> Right t
 274          Nothing -> Left $ Error_Type_Constant_unknown $ At src name
 275
 276 -- * Type 'Error_Type'
 277 data Error_Type src
 278  =   Error_Type_Constant_unknown (At src (Mod NameTy))
 279  |   Error_Type_Con_Kind         (Con_Kind src)
 280  deriving (Eq, Show)
 281 instance ErrorInj (Error_Type src) (Error_Type src) where
 282         errorInj = id
 283 instance ErrorInj (Con_Kind src) (Error_Type src) where
 284         errorInj = Error_Type_Con_Kind
 285
 286 -- | List of the rules of 'Gram_Type'.
 287 gram_type :: Gram_Type () g => [CF g (AST_Type ())]
 288 gram_type =
 289  [ g_type
 290  , g_type_fun
 291  , g_type_list
 292  , g_type_tuple2
 293  , g_type_app
 294  , g_type_atom
 295  , g_type_name_const
 296  , g_type_name_var
 297  -- , g_type_symbol
 298  ]