module Language.Symantic.Typing.Grammar where
import Control.Applicative (Applicative(..))
-import Data.Proxy
+import Data.List (foldl1')
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Char as Char
-import qualified Data.Kind as K
-import qualified Data.Text as Text
-import Language.Symantic.Parsing
+import Language.Symantic.Grammar
+import Language.Symantic.Typing.Variable
--- * Type 'TyName'
-newtype TyName = TyName Text
+-- * Type 'NameTy'
+newtype NameTy = NameTy Text
deriving (Eq, Ord, Show)
-instance IsString TyName where
- fromString = TyName . fromString
+instance IsString NameTy where
+ fromString = NameTy . fromString
-{-
--- * Type 'Token_Type'
-type Token_Type = Type () '[] ()
--- data Token_Type
+-- ** Type 'NameConst'
+type NameConst = NameTy
-instance
- ( Compile_TyNameR TyName cs rs
- , Inj_TyConst cs K.Type
- ) => Compile_TyNameR TyName cs (Proxy K.Type ': rs) where
- compile_TyNameR _rs src (TyName "Type") k = k (tySourced @K.Type src)
- compile_TyNameR _rs src raw k = compile_TyNameR (Proxy @rs) src raw k
-instance Show_TyConst cs => Show_TyConst (Proxy K.Type ': cs) where
- show_TyConst TyConstZ{} = "Type"
- show_TyConst (TyConstS c) = show_TyConst c
--}
+-- ** Type 'NameFam'
+type NameFam = NameTy
-- * Type 'AST_Type'
-type AST_Type src = BinTree (EToken src '[Proxy K.Type])
-type AST_Term src is = BinTree (EToken src is)
+-- | /Abstract Syntax Tree/ of 'Token_Type'.
+type AST_Type src = BinTree (Token_Type src) -- (EToken src '[Proxy K.Type])
-data instance TokenT src ts (Proxy K.Type)
- = Token_Type_Name TyName
-
-deriving instance Eq_Token src ts => Eq (TokenT src ts (Proxy K.Type))
-deriving instance Show_Token src ts => Show (TokenT src ts (Proxy K.Type))
+-- ** Type 'Token_Type'
+data Token_Type src
+ = Token_Type_Const (At src NameTy)
+ | Token_Type_Var (At src NameVar)
+ -- deriving (Eq, Show)
+instance Source src => Eq (Token_Type src) where
+ Token_Type_Const (At _ x) == Token_Type_Const (At _ y) = x == y
+ Token_Type_Var (At _ x) == Token_Type_Var (At _ y) = x == y
+ _ == _ = False
+instance Source src => Show (Token_Type src) where
+ showsPrec p (Token_Type_Const (At _ x)) =
+ showParen (p >= 10) $
+ showString "Token_Type_Const" .
+ showChar ' ' . showsPrec 10 x
+ showsPrec p (Token_Type_Var (At _ x)) =
+ showParen (p >= 10) $
+ showString "Token_Type_Var" .
+ showChar ' ' . showsPrec 10 x
-- * Class 'Gram_Type'
-- | Read an 'AST_Type' from a textual source.
class
- ( Alt g
- , Alter g
- , App g
- , Try g
- , Gram_CF g
- , Gram_Rule g
+ ( Gram_Source src g
, Gram_Terminal g
- , Gram_Lexer g
+ , Gram_Rule g
+ , Gram_Alt g
+ , Gram_Try g
+ , Gram_App g
+ , Gram_AltApp g
+ , Gram_CF g
+ , Gram_Comment g
, Gram_Op g
- , Gram_Meta (Text_of_Source src) g
- , Inj_Source (Text_of_Source src) src
) => Gram_Type src g where
g_type :: CF g (AST_Type src)
g_type = rule "type" $ g_type_fun
g_type_fun :: CF g (AST_Type src)
g_type_fun = rule "type_fun" $
- infixrG g_type_list (sourceG $ op <$ symbol "->")
- where op src = BinTree1 . BinTree1 (BinTree0 $ inj_EToken src $ Token_Type_Name "(->)")
+ infixrG g_type_list (g_source $ op <$ symbol "->")
+ where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src "(->)")
-- TODO: maybe not harcoding g_type_list and g_type_tuple2
g_type_list :: CF g (AST_Type src)
g_type_list = rule "type_list" $
- sourceG $ inside f
- (symbol "[") (optional (g_type)) (symbol "]")
+ g_source $ inside mk
+ (symbol "[") (optional g_type) (symbol "]")
(const <$> g_type_tuple2)
where
- n src = BinTree0 $ inj_EToken src $ Token_Type_Name "[]"
- f Nothing src = n src
- f (Just a) src = BinTree1 (n src) a
+ mk Nothing src = tok src
+ mk (Just a) src = BinTree2 (tok src) a
+ tok src = BinTree0 $ Token_Type_Const $ At src "[]"
g_type_tuple2 :: CF g (AST_Type src)
g_type_tuple2 = rule "type_tuple2" $
- try (parens (infixrG g_type (sourceG $ op <$ symbol ","))) <+> g_type_app
- where op src = BinTree1 . BinTree1 (BinTree0 $ inj_EToken src $ Token_Type_Name "(,)")
+ try (parens (infixrG (g_type) (g_source $ op <$ symbol ","))) <+> (g_type_app)
+ where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src "(,)")
g_type_app :: CF g (AST_Type src)
g_type_app = rule "type_app" $
- foldr1 BinTree1 <$> some g_type_atom
+ foldl1' BinTree2 <$> some (g_type_atom)
g_type_atom :: CF g (AST_Type src)
g_type_atom = rule "type_atom" $
try (parens g_type) <+>
- g_type_name <+>
+ g_type_name_const <+>
+ g_type_name_var <+>
g_type_symbol
- g_type_name :: CF g (AST_Type src)
- g_type_name = rule "type_name" $
- sourceG $ lexeme $
- (\c cs src -> BinTree0 $ inj_EToken src $ Token_Type_Name $ fromString $ c:cs)
+ g_type_name_const :: CF g (AST_Type src)
+ g_type_name_const = rule "type_name_const" $
+ lexeme $ g_source $
+ (\n ns src -> BinTree0 $ Token_Type_Const $ At src $ fromString $ n:ns)
<$> unicat (Unicat Char.UppercaseLetter)
<*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
+ g_type_name_var :: CF g (AST_Type src)
+ g_type_name_var = rule "type_name_var" $
+ lexeme $ g_source $
+ (\n ns src -> BinTree0 $ Token_Type_Var $ At src $ fromString $ n:ns)
+ <$> unicat (Unicat Char.LowercaseLetter)
+ <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
g_type_symbol :: CF g (AST_Type src)
g_type_symbol = rule "type_symbol" $
- sourceG $ (f <$>) $
+ g_source $ (mk <$>) $
parens $ many $ cf_of_Terminal $ choice g_ok `but` choice g_ko
where
- f s src = BinTree0 $ inj_EToken src $ (Token_Type_Name) $
- TyName $ Text.concat ["(", Text.pack s, ")"]
+ mk s src = BinTree0 $ Token_Type_Const $ At src (fromString $ "(" ++ s ++ ")")
g_ok = unicat <$>
[ Unicat_Symbol
, Unicat_Punctuation
g_ko = char <$> ['(', ')', '`']
deriving instance Gram_Type src g => Gram_Type src (CF g)
-instance
- ( Inj_Source (Text_of_Source src) src
- ) => Gram_Type src EBNF
-instance
- ( Inj_Source (Text_of_Source src) src
- ) => Gram_Type src RuleDef
+instance Gram_Source src EBNF => Gram_Type src EBNF
+instance Gram_Source src RuleEBNF => Gram_Type src RuleEBNF
-- | List of the rules of 'Gram_Type'.
-gram_type :: Gram_Type src g => [CF g (AST_Type src)]
+gram_type :: Gram_Type () g => [CF g (AST_Type ())]
gram_type =
[ g_type
, g_type_fun
, g_type_tuple2
, g_type_app
, g_type_atom
- , g_type_name
+ , g_type_name_const
+ , g_type_name_var
, g_type_symbol
]
sourcephile / git / haskell / symantic.git / blobdiff