]> Git — Sourcephile - haskell/symantic.git/blob - symantic/Language/Symantic/Typing/Grammar.hs
Change Term to be a GADT, to avoid type applications and allow TypeOf Term.
[haskell/symantic.git] / symantic / Language / Symantic / Typing / Grammar.hs
1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE UndecidableInstances #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Language.Symantic.Typing.Grammar where
5
6 import Control.Applicative (Applicative(..))
7 import Data.List (foldl1')
8 import Data.String (IsString(..))
9 import Data.Text (Text)
10 import qualified Data.Char as Char
11
12 import Language.Symantic.Grammar
13 import Language.Symantic.Typing.Variable
14
15 -- * Type 'NameTy'
16 newtype NameTy = NameTy Text
17 deriving (Eq, Ord, Show)
18 instance IsString NameTy where
19 fromString = NameTy . fromString
20
21 -- ** Type 'NameConst'
22 type NameConst = NameTy
23
24 -- ** Type 'NameFam'
25 type NameFam = NameTy
26
27 -- * Type 'AST_Type'
28 -- | /Abstract Syntax Tree/ of 'Token_Type'.
29 type AST_Type src = BinTree (Token_Type src) -- (EToken src '[Proxy K.Type])
30
31 -- ** Type 'Token_Type'
32 data Token_Type src
33 = Token_Type_Const (At src NameTy)
34 | Token_Type_Var (At src NameVar)
35 -- deriving (Eq, Show)
36 instance Source src => Eq (Token_Type src) where
37 Token_Type_Const (At _ x) == Token_Type_Const (At _ y) = x == y
38 Token_Type_Var (At _ x) == Token_Type_Var (At _ y) = x == y
39 _ == _ = False
40 instance Source src => Show (Token_Type src) where
41 showsPrec p (Token_Type_Const (At _ x)) =
42 showParen (p >= 10) $
43 showString "Token_Type_Const" .
44 showChar ' ' . showsPrec 10 x
45 showsPrec p (Token_Type_Var (At _ x)) =
46 showParen (p >= 10) $
47 showString "Token_Type_Var" .
48 showChar ' ' . showsPrec 10 x
49
50 -- * Class 'Gram_Type'
51 -- | Read an 'AST_Type' from a textual source.
52 class
53 ( Gram_Source src g
54 , Gram_Terminal g
55 , Gram_Rule g
56 , Gram_Alt g
57 , Gram_Try g
58 , Gram_App g
59 , Gram_AltApp g
60 , Gram_CF g
61 , Gram_Comment g
62 , Gram_Op g
63 ) => Gram_Type src g where
64 g_type :: CF g (AST_Type src)
65 g_type = rule "type" $ g_type_fun
66 g_type_fun :: CF g (AST_Type src)
67 g_type_fun = rule "type_fun" $
68 infixrG g_type_list (g_source $ op <$ symbol "->")
69 where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src "(->)")
70 -- TODO: maybe not harcoding g_type_list and g_type_tuple2
71 g_type_list :: CF g (AST_Type src)
72 g_type_list = rule "type_list" $
73 g_source $ inside mk
74 (symbol "[") (optional g_type) (symbol "]")
75 (const <$> g_type_tuple2)
76 where
77 mk Nothing src = tok src
78 mk (Just a) src = BinTree2 (tok src) a
79 tok src = BinTree0 $ Token_Type_Const $ At src "[]"
80 g_type_tuple2 :: CF g (AST_Type src)
81 g_type_tuple2 = rule "type_tuple2" $
82 try (parens (infixrG (g_type) (g_source $ op <$ symbol ","))) <+> (g_type_app)
83 where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src "(,)")
84 g_type_app :: CF g (AST_Type src)
85 g_type_app = rule "type_app" $
86 foldl1' BinTree2 <$> some (g_type_atom)
87 g_type_atom :: CF g (AST_Type src)
88 g_type_atom = rule "type_atom" $
89 try (parens g_type) <+>
90 g_type_name_const <+>
91 g_type_name_var <+>
92 g_type_symbol
93 g_type_name_const :: CF g (AST_Type src)
94 g_type_name_const = rule "type_name_const" $
95 lexeme $ g_source $
96 (\n ns src -> BinTree0 $ Token_Type_Const $ At src $ fromString $ n:ns)
97 <$> unicat (Unicat Char.UppercaseLetter)
98 <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
99 g_type_name_var :: CF g (AST_Type src)
100 g_type_name_var = rule "type_name_var" $
101 lexeme $ g_source $
102 (\n ns src -> BinTree0 $ Token_Type_Var $ At src $ fromString $ n:ns)
103 <$> unicat (Unicat Char.LowercaseLetter)
104 <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
105 g_type_symbol :: CF g (AST_Type src)
106 g_type_symbol = rule "type_symbol" $
107 g_source $ (mk <$>) $
108 parens $ many $ cf_of_Terminal $ choice g_ok `but` choice g_ko
109 where
110 mk s src = BinTree0 $ Token_Type_Const $ At src (fromString $ "(" ++ s ++ ")")
111 g_ok = unicat <$>
112 [ Unicat_Symbol
113 , Unicat_Punctuation
114 , Unicat_Mark
115 ]
116 g_ko = char <$> ['(', ')', '`']
117
118 deriving instance Gram_Type src g => Gram_Type src (CF g)
119 instance Gram_Source src EBNF => Gram_Type src EBNF
120 instance Gram_Source src RuleEBNF => Gram_Type src RuleEBNF
121
122 -- | List of the rules of 'Gram_Type'.
123 gram_type :: Gram_Type () g => [CF g (AST_Type ())]
124 gram_type =
125 [ g_type
126 , g_type_fun
127 , g_type_list
128 , g_type_tuple2
129 , g_type_app
130 , g_type_atom
131 , g_type_name_const
132 , g_type_name_var
133 , g_type_symbol
134 ]