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  ]