]> Git — Sourcephile - haskell/symantic.git/blob - symantic/Language/Symantic/Typing/Grammar.hs
Clarification : eqKi -> eqKind.
[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
37 -- * Class 'Gram_Type'
38 -- | Read an 'AST_Type' from a textual source.
39 class
40 ( Gram_Source src g
41 , Gram_Terminal g
42 , Gram_Rule g
43 , Gram_Alt g
44 , Gram_Try g
45 , Gram_App g
46 , Gram_AltApp g
47 , Gram_CF g
48 , Gram_Comment g
49 , Gram_Op g
50 ) => Gram_Type src g where
51 g_type :: CF g (AST_Type src)
52 g_type = rule "type" $ g_type_fun
53 g_type_fun :: CF g (AST_Type src)
54 g_type_fun = rule "type_fun" $
55 infixrG g_type_list (g_source $ op <$ symbol "->")
56 where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src "(->)")
57 -- TODO: maybe not harcoding g_type_list and g_type_tuple2
58 g_type_list :: CF g (AST_Type src)
59 g_type_list = rule "type_list" $
60 g_source $ inside mk
61 (symbol "[") (optional g_type) (symbol "]")
62 (const <$> g_type_tuple2)
63 where
64 mk Nothing src = tok src
65 mk (Just a) src = BinTree2 (tok src) a
66 tok src = BinTree0 $ Token_Type_Const $ At src "[]"
67 g_type_tuple2 :: CF g (AST_Type src)
68 g_type_tuple2 = rule "type_tuple2" $
69 try (parens (infixrG (g_type) (g_source $ op <$ symbol ","))) <+> (g_type_app)
70 where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src "(,)")
71 g_type_app :: CF g (AST_Type src)
72 g_type_app = rule "type_app" $
73 foldl1' BinTree2 <$> some (g_type_atom)
74 g_type_atom :: CF g (AST_Type src)
75 g_type_atom = rule "type_atom" $
76 try (parens g_type) <+>
77 g_type_name_const <+>
78 g_type_name_var <+>
79 g_type_symbol
80 g_type_name_const :: CF g (AST_Type src)
81 g_type_name_const = rule "type_name_const" $
82 lexeme $ g_source $
83 (\n ns src -> BinTree0 $ Token_Type_Const $ At src $ fromString $ n:ns)
84 <$> unicat (Unicat Char.UppercaseLetter)
85 <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
86 g_type_name_var :: CF g (AST_Type src)
87 g_type_name_var = rule "type_name_var" $
88 lexeme $ g_source $
89 (\n ns src -> BinTree0 $ Token_Type_Var $ At src $ fromString $ n:ns)
90 <$> unicat (Unicat Char.LowercaseLetter)
91 <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
92 g_type_symbol :: CF g (AST_Type src)
93 g_type_symbol = rule "type_symbol" $
94 g_source $ (mk <$>) $
95 parens $ many $ cf_of_Terminal $ choice g_ok `but` choice g_ko
96 where
97 mk s src = BinTree0 $ Token_Type_Const $ At src (fromString $ "(" ++ s ++ ")")
98 g_ok = unicat <$>
99 [ Unicat_Symbol
100 , Unicat_Punctuation
101 , Unicat_Mark
102 ]
103 g_ko = char <$> ['(', ')', '`']
104
105 deriving instance Gram_Type src g => Gram_Type src (CF g)
106 instance Gram_Source src EBNF => Gram_Type src EBNF
107 instance Gram_Source src RuleEBNF => Gram_Type src RuleEBNF
108
109 -- | List of the rules of 'Gram_Type'.
110 gram_type :: Gram_Type () g => [CF g (AST_Type ())]
111 gram_type =
112 [ g_type
113 , g_type_fun
114 , g_type_list
115 , g_type_tuple2
116 , g_type_app
117 , g_type_atom
118 , g_type_name_const
119 , g_type_name_var
120 , g_type_symbol
121 ]