Add make target %/fast.

[haskell/symantic.git] / symantic / Language / Symantic / Typing / Grammar.hs

diff --git a/symantic/Language/Symantic/Typing/Grammar.hs b/symantic/Language/Symantic/Typing/Grammar.hs
index 08ddbb688d424fe7db4a995e11a2866ae99f2709..e4d9efe746301f01f357ca0124dcd3ed63bead34 100644 (file)
--- a/symantic/Language/Symantic/Typing/Grammar.hs
+++ b/symantic/Language/Symantic/Typing/Grammar.hs
@@ -32,12 +32,26 @@ type AST_Type src = BinTree (Token_Type src) -- (EToken src '[Proxy K.Type])
 data Token_Type src
  =   Token_Type_Const (At src NameTy)
  |   Token_Type_Var   (At src NameVar)
- deriving (Eq, Show)
+ -- 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
- ( Gram_Terminal g
+ ( Gram_Source src g
+ , Gram_Terminal g
  , Gram_Rule g
  , Gram_Alt g
  , Gram_Try g
@@ -46,19 +60,17 @@ class
  , 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 (withSource $ op <$ symbol "->")
+               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" $
-               withSource $ inside mk
+               g_source $ inside mk
                 (symbol "[") (optional g_type) (symbol "]")
                 (const <$> g_type_tuple2)
                where
@@ -67,7 +79,7 @@ class
                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) (withSource $ op <$ symbol ","))) <+> (g_type_app)
+               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" $
@@ -80,19 +92,19 @@ class
                g_type_symbol
        g_type_name_const :: CF g (AST_Type src)
        g_type_name_const = rule "type_name_const" $
-               lexeme $ withSource $
+               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 $ withSource $
+               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" $
-               withSource $ (mk <$>) $
+               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 ++ ")")
@@ -104,8 +116,8 @@ class
                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 RuleEBNF
+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 () g => [CF g (AST_Type ())]