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.Proxy
   9 import Data.String (IsString(..))
  10 import Data.Text (Text)
  11 import qualified Data.Char as Char
  12 import qualified Data.Kind as K
  13 import qualified Data.Text as Text
  14
  15 import Language.Symantic.Parsing
  16
  17 -- * Type 'TyName'
  18 newtype TyName = TyName Text
  19  deriving (Eq, Ord, Show)
  20 instance IsString TyName where
  21         fromString = TyName . fromString
  22
  23 {-
  24 -- * Type 'Token_Type'
  25 type Token_Type = Type () '[] ()
  26 -- data Token_Type
  27
  28 instance
  29  ( Compile_TyNameR TyName cs rs
  30  , Inj_TyConst cs K.Type
  31  ) => Compile_TyNameR TyName cs (Proxy K.Type ': rs) where
  32         compile_TyNameR _rs src (TyName "Type") k = k (tySourced @K.Type src)
  33         compile_TyNameR _rs src raw k = compile_TyNameR (Proxy @rs) src raw k
  34 instance Show_TyConst cs => Show_TyConst (Proxy K.Type ': cs) where
  35         show_TyConst TyConstZ{} = "Type"
  36         show_TyConst (TyConstS c) = show_TyConst c
  37 -}
  38
  39 -- * Type 'AST_Type'
  40 type AST_Type src = BinTree (EToken src '[Proxy K.Type])
  41
  42 data instance TokenT ss (Proxy K.Type)
  43  = Token_Type_Name TyName
  44
  45 deriving instance Eq_Token   ss => Eq   (TokenT ss (Proxy K.Type))
  46 deriving instance Show_Token ss => Show (TokenT ss (Proxy K.Type))
  47
  48 -- * Class 'Gram_Type'
  49 -- | Read an 'AST_Type' from a textual source.
  50 class
  51  ( Alt g
  52  , Alter g
  53  , App g
  54  , Try g
  55  , Gram_CF g
  56  , Gram_Rule g
  57  , Gram_Terminal g
  58  , Gram_Lexer g
  59  , Gram_Op g
  60  , Gram_Meta (Text_of_Source src) g
  61  , Inj_Source (Text_of_Source src) src
  62  ) => Gram_Type src g where
  63         g_type :: CF g (AST_Type src)
  64         g_type = rule "type" $ g_type_fun
  65         g_type_fun :: CF g (AST_Type src)
  66         g_type_fun = rule "type_fun" $
  67                 infixrG g_type_list (sourceG $ op <$ symbol "->")
  68                 where op src = BinTree1 . BinTree1 (BinTree0 $ inj_EToken src $ Token_Type_Name "(->)")
  69         -- TODO: maybe not harcoding g_type_list and g_type_tuple2
  70         g_type_list :: CF g (AST_Type src)
  71         g_type_list = rule "type_list" $
  72                 sourceG $ inside f
  73                  (symbol "[") (optional (g_type)) (symbol "]")
  74                  (const <$> g_type_tuple2)
  75                 where
  76                 n src = BinTree0 $ inj_EToken src $ Token_Type_Name "[]"
  77                 f Nothing  src = n src
  78                 f (Just a) src = BinTree1 (n src) a
  79         g_type_tuple2 :: CF g (AST_Type src)
  80         g_type_tuple2 = rule "type_tuple2" $
  81                 try (parens (infixrG g_type (sourceG $ op <$ symbol ","))) <+> g_type_app
  82                 where op src = BinTree1 . BinTree1 (BinTree0 $ inj_EToken src $ Token_Type_Name "(,)")
  83         g_type_app :: CF g (AST_Type src)
  84         g_type_app = rule "type_app" $
  85                 foldl1' BinTree1 <$> some g_type_atom
  86         g_type_atom :: CF g (AST_Type src)
  87         g_type_atom = rule "type_atom" $
  88                 try (parens g_type) <+>
  89                 g_type_name <+>
  90                 g_type_symbol
  91         g_type_name :: CF g (AST_Type src)
  92         g_type_name = rule "type_name" $
  93                 sourceG $ lexeme $
  94                 (\c cs src -> BinTree0 $ inj_EToken src $ Token_Type_Name $ fromString $ c:cs)
  95                  <$> unicat (Unicat Char.UppercaseLetter)
  96                  <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
  97         g_type_symbol :: CF g (AST_Type src)
  98         g_type_symbol = rule "type_symbol" $
  99                 sourceG $ (f <$>) $
 100                 parens $ many $ cf_of_Terminal $ choice g_ok `but` choice g_ko
 101                 where
 102                 f s src = BinTree0 $ inj_EToken src $ (Token_Type_Name) $
 103                         TyName $ Text.concat ["(", Text.pack s, ")"]
 104                 g_ok = unicat <$>
 105                  [ Unicat_Symbol
 106                  , Unicat_Punctuation
 107                  , Unicat_Mark
 108                  ]
 109                 g_ko = char <$> ['(', ')', '`']
 110
 111 deriving instance Gram_Type src g => Gram_Type src (CF g)
 112 instance
 113  ( Inj_Source (Text_of_Source src) src
 114  ) => Gram_Type src EBNF
 115 instance
 116  ( Inj_Source (Text_of_Source src) src
 117  ) => Gram_Type src RuleDef
 118
 119 -- | List of the rules of 'Gram_Type'.
 120 gram_type :: Gram_Type src g => [CF g (AST_Type src)]
 121 gram_type =
 122  [ g_type
 123  , g_type_fun
 124  , g_type_list
 125  , g_type_tuple2
 126  , g_type_app
 127  , g_type_atom
 128  , g_type_name
 129  , g_type_symbol
 130  ]