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