module Language.Symantic.Typing.Grammar where
import Control.Applicative (Applicative(..))
import Data.List (foldl1')
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Char as Char
import Language.Symantic.Grammar
import Language.Symantic.Typing.Variable
newtype NameTy = NameTy Text
deriving (Eq, Ord, Show)
instance IsString NameTy where
fromString = NameTy . fromString
type NameConst = NameTy
type NameFam = NameTy
type AST_Type src = BinTree (Token_Type src)
data Token_Type src
= Token_Type_Const (At src NameTy)
| Token_Type_Var (At src NameVar)
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_Source src g
, Gram_Terminal 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_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 (g_source $ op <$ symbol "->")
where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src "(->)")
g_type_list :: CF g (AST_Type src)
g_type_list = rule "type_list" $
g_source $ inside mk
(symbol "[") (optional g_type) (symbol "]")
(const <$> g_type_tuple2)
where
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) (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" $
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_const <+>
g_type_name_var <+>
g_type_symbol
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" $
g_source $ (mk <$>) $
parens $ many $ cf_of_Terminal $ choice g_ok `but` choice g_ko
where
mk s src = BinTree0 $ Token_Type_Const $ At src (fromString $ "(" ++ s ++ ")")
g_ok = unicat <$>
[ Unicat_Symbol
, Unicat_Punctuation
, Unicat_Mark
]
g_ko = char <$> ['(', ')', '`']
deriving instance Gram_Type src g => Gram_Type src (CF g)
instance Gram_Source src EBNF => Gram_Type src EBNF
instance Gram_Source src RuleEBNF => Gram_Type src RuleEBNF
gram_type :: Gram_Type () g => [CF g (AST_Type ())]
gram_type =
[ g_type
, g_type_fun
, g_type_list
, g_type_tuple2
, g_type_app
, g_type_atom
, g_type_name_const
, g_type_name_var
, g_type_symbol
]