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.Proxy (Proxy(..))
  11 import Data.Semigroup (Semigroup(..))
  12 import Data.String (IsString(..))
  13 import Prelude hiding (any)
  14 import qualified Data.Char as Char
  15 import qualified Data.Text as Text
  16 import Data.Map.Strict (Map)
  17 import qualified Data.Map.Strict as Map
  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 (At src (Mod NameTy))
  33  |   Token_Type_Var   (At src NameVar)
  34  -- deriving (Eq, Show)
  35 instance Source src => Eq (Token_Type src) where
  36         Token_Type_Const (At _ x) == Token_Type_Const (At _ y) = x == y
  37         Token_Type_Var   (At _ x) == Token_Type_Var   (At _ y) = x == y
  38         _ == _ = False
  39 instance Source src => Show (Token_Type src) where
  40         showsPrec p (Token_Type_Const (At _ 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 -- ** Class 'ModulesTyInj'
  64 -- | Derive a 'ModulesTy' from the given type-level list
  65 -- of 'Proxy'-fied /type constants/.
  66 class ModulesTyInj ts where
  67         modulesTyInj :: Source src => ModulesTy src
  68 instance ModulesTyInj '[] where
  69         modulesTyInj = Map.empty
  70 instance
  71  ( KindInjP (Ty_of_Type (K c))
  72  , K c ~ Type_of_Ty (Ty_of_Type (K c))
  73  , Constable c
  74  , ModulesTyInj ts
  75  ) => ModulesTyInj (Proxy c ': ts) where
  76         modulesTyInj =
  77                 Map.insert
  78                  (nameTyOf $ Proxy @c)
  79                  (TypeTLen $ \len -> TypeT $ TyConst noSource len $
  80                         constKiInj @(K c) @c $
  81                         kindInjP @(Ty_of_Type (K c)) noSource) $
  82                 modulesTyInj @ts
  83
  84
  85 -- * Class 'Gram_Mod'
  86 class
  87  ( Gram_Terminal g
  88  , Gram_Rule g
  89  , Gram_Alt g
  90  , Gram_Try g
  91  , Gram_App g
  92  , Gram_AltApp g
  93  , Gram_RegL g
  94  , Gram_CF g
  95  , Gram_Comment g
  96  , Gram_Op g
  97  ) => Gram_Mod g where
  98         g_PathMod :: CF g PathMod
  99         g_PathMod = rule "PathMod" $
 100                 infixrG
 101                  (pure <$> g_NameMod)
 102                  (op <$ char '.')
 103                 where op = (<>)
 104         g_NameMod :: CF g NameMod
 105         g_NameMod = rule "NameMod" $
 106                 NameMod . Text.pack <$> identG
 107                 where
 108                 identG = (:) <$> headG <*> many (cfOf tailG)
 109                 headG = unicat $ Unicat Char.UppercaseLetter
 110                 tailG :: Terminal g Char
 111                 tailG =
 112                         unicat Unicat_Letter <+>
 113                         unicat Unicat_Number
 114
 115 deriving instance Gram_Mod g => Gram_Mod (CF g)
 116 instance Gram_Mod EBNF
 117 instance Gram_Mod RuleEBNF
 118
 119 -- * Class 'Gram_Type_Name'
 120 class
 121  ( Gram_Terminal g
 122  , Gram_Rule g
 123  , Gram_Alt g
 124  , Gram_Try g
 125  , Gram_App g
 126  , Gram_AltApp g
 127  , Gram_RegL g
 128  , Gram_CF g
 129  , Gram_Comment g
 130  , Gram_Op g
 131  , Gram_Mod g
 132  ) => Gram_Type_Name g where
 133         g_ModNameTy :: CF g (Mod NameTy)
 134         g_ModNameTy = rule "ModNameTy" $
 135                 lexeme $
 136                         g_ModNameTyId <+>
 137                         parens g_ModNameTyOp
 138
 139         g_ModNameTyId :: CF g (Mod NameTy)
 140         g_ModNameTyId = rule "ModNameTyId" $
 141                 Mod
 142                  <$> option [] (try $ g_PathMod <* char '.')
 143                  <*> g_NameTyId
 144         g_NameTyId :: CF g NameTy
 145         g_NameTyId = rule "NameTyId" $
 146                 NameTy . Text.pack <$> identTyG
 147                 where
 148                 identTyG = (:) <$> headTyG <*> many (cfOf tailTyG)
 149                 headTyG = unicat $ Unicat Char.UppercaseLetter
 150                 tailTyG :: Terminal g Char
 151                 tailTyG =
 152                         unicat Unicat_Letter <+>
 153                         unicat Unicat_Number
 154
 155         g_ModNameTyOp :: CF g (Mod NameTy)
 156         g_ModNameTyOp = rule "ModNameTyOp" $
 157                 Mod
 158                  <$> option [] (try $ g_PathMod <* char '.')
 159                  <*> g_NameTyOp
 160         g_NameTyOp :: CF g NameTy
 161         g_NameTyOp = rule "NameTyOp" $
 162                 NameTy . Text.pack <$> many (cfOf okG)
 163                 where
 164                 okG :: Terminal g Char
 165                 okG = choice (unicat <$>
 166                          [ Unicat_Symbol
 167                          , Unicat_Punctuation
 168                          , Unicat_Mark
 169                          ]) `but` koG
 170                 koG = choice (char <$> ['(', ')', '`', '\'', '[', ']'])
 171
 172 deriving instance Gram_Type_Name g => Gram_Type_Name (CF g)
 173 instance Gram_Type_Name EBNF
 174 instance Gram_Type_Name RuleEBNF
 175
 176 -- * Class 'Gram_Type'
 177 -- | Read an 'AST_Type' from a textual source.
 178 class
 179  ( Gram_Source src g
 180  , Gram_Terminal g
 181  , Gram_Rule g
 182  , Gram_Alt g
 183  , Gram_Try g
 184  , Gram_App g
 185  , Gram_AltApp g
 186  , Gram_CF g
 187  , Gram_Comment g
 188  , Gram_Op g
 189  , Gram_Type_Name g
 190  , NameTyOf (->)
 191  , NameTyOf []
 192  , NameTyOf (,)
 193  ) => Gram_Type src g where
 194         g_type :: CF g (AST_Type src)
 195         g_type = rule "type" $ g_type_fun
 196         g_type_fun :: CF g (AST_Type src)
 197         g_type_fun = rule "type_fun" $
 198                 infixrG g_type_list (source $ op <$ symbol "->")
 199                 where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src $ nameTyOf $ Proxy @(->))
 200         -- TODO: maybe not harcoding g_type_list and g_type_tuple2
 201         g_type_list :: CF g (AST_Type src)
 202         g_type_list = rule "type_list" $
 203                 source $ inside mk
 204                  (symbol "[") (optional g_type) (symbol "]")
 205                  (const <$> g_type_tuple2)
 206                 where
 207                 mk Nothing  src = tok src
 208                 mk (Just a) src = BinTree2 (tok src) a
 209                 tok src = BinTree0 $ Token_Type_Const $ At src $ nameTyOf $ Proxy @[]
 210         g_type_tuple2 :: CF g (AST_Type src)
 211         g_type_tuple2 = rule "type_tuple2" $
 212                 try (parens (infixrG (g_type) (source $ op <$ symbol ","))) <+> (g_type_app)
 213                 where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src $ nameTyOf $ Proxy @(,))
 214         g_type_app :: CF g (AST_Type src)
 215         g_type_app = rule "type_app" $
 216                 foldl1' BinTree2 <$> some (g_type_atom)
 217         g_type_atom :: CF g (AST_Type src)
 218         g_type_atom = rule "type_atom" $
 219                 try (parens g_type) <+>
 220                 g_type_name_const <+>
 221                 g_type_name_var
 222                 -- <+> g_type_symbol
 223         g_type_name_const :: CF g (AST_Type src)
 224         g_type_name_const = rule "type_name_const" $
 225                 lexeme $ source $
 226                 (\n src -> BinTree0 $ Token_Type_Const $ At src n)
 227                  <$> g_ModNameTy
 228                  -- <$> unicat (Unicat Char.UppercaseLetter)
 229                  -- <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
 230         g_type_name_var :: CF g (AST_Type src)
 231         g_type_name_var = rule "type_name_var" $
 232                 lexeme $ source $
 233                 (\n ns src -> BinTree0 $ Token_Type_Var $ At src $ fromString $ n:ns)
 234                  <$> unicat (Unicat Char.LowercaseLetter)
 235                  <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
 236         {-
 237         g_type_symbol :: CF g (AST_Type src)
 238         g_type_symbol = rule "type_symbol" $
 239                 source $ (mk <$>) $
 240                 parens $ many $ cfOf $ choice g_ok `but` choice g_ko
 241                 where
 242                 mk s src = BinTree0 $ Token_Type_Const $ At src $ Mod [] $ fromString $ "(" ++ s ++ ")"
 243                 g_ok = unicat <$>
 244                  [ Unicat_Symbol
 245                  , Unicat_Punctuation
 246                  , Unicat_Mark
 247                  ]
 248                 g_ko = char <$> ['(', ')', '`']
 249         -}
 250
 251 deriving instance Gram_Type src g => Gram_Type src (CF g)
 252 instance
 253  ( Gram_Source src EBNF
 254  , NameTyOf (->)
 255  , NameTyOf (,)
 256  , NameTyOf []
 257  ) => Gram_Type src EBNF
 258 instance
 259  ( Gram_Source src RuleEBNF
 260  , NameTyOf (->)
 261  , NameTyOf (,)
 262  , NameTyOf []
 263  ) => Gram_Type src RuleEBNF
 264
 265 -- | List of the rules of 'Gram_Type'.
 266 gram_type :: Gram_Type () g => [CF g (AST_Type ())]
 267 gram_type =
 268  [ g_type
 269  , g_type_fun
 270  , g_type_list
 271  , g_type_tuple2
 272  , g_type_app
 273  , g_type_atom
 274  , g_type_name_const
 275  , g_type_name_var
 276  -- , g_type_symbol
 277  ]