symantic/Language/Symantic/Compiling/Grammar.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE ExistentialQuantification #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE PolyKinds #-}
   6 {-# LANGUAGE UndecidableInstances #-}
   7 module Language.Symantic.Compiling.Grammar where
   8
   9 import Control.Arrow (left)
  10 import Control.Monad (void)
  11 import Data.Proxy (Proxy(..))
  12 import Data.Semigroup (Semigroup(..))
  13 import Prelude hiding (mod, not, any)
  14 import qualified Data.Char as Char
  15 import qualified Data.Function as Fun
  16 import qualified Data.Map.Strict as Map
  17 import qualified Data.Text as Text
  18
  19 import Language.Symantic.Grammar as G
  20 import Language.Symantic.Typing
  21 import Language.Symantic.Compiling.Module
  22
  23 -- * Class 'Gram_Name'
  24 class
  25  ( Gram_Terminal g
  26  , Gram_Rule g
  27  , Gram_Alt g
  28  , Gram_Try g
  29  , Gram_App g
  30  , Gram_AltApp g
  31  , Gram_RegL g
  32  , Gram_CF g
  33  , Gram_Comment g
  34  , Gram_Op g
  35  ) => Gram_Name g where
  36         g_mod_path :: CF g PathMod
  37         g_mod_path = rule "mod_path" $
  38                 infixrG
  39                  (pure <$> g_mod_name)
  40                  (op <$ char '.')
  41                 where op = (<>)
  42         g_mod_name :: CF g NameMod
  43         g_mod_name = rule "mod_name" $
  44                 (NameMod . Text.pack <$>) $
  45                 (identG `minus`) $
  46                 Fun.const
  47                  <$> g_term_keywords
  48                  <*. (any `but` g_term_idname_tail)
  49                 where
  50                 identG = (:) <$> headG <*> many (G.cfOf g_term_idname_tail)
  51                 headG  = unicat $ Unicat Char.UppercaseLetter
  52
  53         g_term_mod_name :: CF g (Mod NameTe)
  54         g_term_mod_name = rule "term_mod_name" $
  55                 lexeme $
  56                         g_term_mod_idname <+>
  57                         parens g_term_mod_opname
  58         g_term_name :: CF g NameTe
  59         g_term_name = rule "term_name" $
  60                 lexeme $
  61                         g_term_idname <+>
  62                         parens g_term_opname
  63
  64         g_term_mod_idname :: CF g (Mod NameTe)
  65         g_term_mod_idname = rule "term_mod_idname" $
  66                 Mod
  67                  <$> option [] (try $ g_mod_path <* char '.')
  68                  <*> g_term_idname
  69         g_term_idname :: CF g NameTe
  70         g_term_idname = rule "term_idname" $
  71                 (NameTe . Text.pack <$>) $
  72                 (identG `minus`) $
  73                 Fun.const
  74                  <$> g_term_keywords
  75                  <*. (any `but` g_term_idname_tail)
  76                 where
  77                 identG = (:) <$> headG <*> many (G.cfOf g_term_idname_tail)
  78                 headG  = unicat $ Unicat_Letter
  79         g_term_idname_tail :: Terminal g Char
  80         g_term_idname_tail = rule "term_idname_tail" $
  81                 unicat Unicat_Letter <+>
  82                 unicat Unicat_Number
  83         g_term_keywords :: Reg rl g String
  84         g_term_keywords = rule "term_keywords" $
  85                 choice $ string <$> ["in", "let"]
  86
  87         g_term_mod_opname :: CF g (Mod NameTe)
  88         g_term_mod_opname = rule "term_mod_opname" $
  89                 Mod
  90                  <$> option [] (try $ g_mod_path <* char '.')
  91                  <*> g_term_opname
  92         g_term_opname :: CF g NameTe
  93         g_term_opname = rule "term_opname" $
  94                 (NameTe . Text.pack <$>) $
  95                 (symG `minus`) $
  96                 Fun.const
  97                  <$> g_term_keysyms
  98                  <*. (any `but` g_term_opname_ok)
  99                 where
 100                 symG = some $ G.cfOf g_term_opname_ok
 101         g_term_opname_ok :: Terminal g Char
 102         g_term_opname_ok = rule "term_opname_ok" $
 103                 choice (unicat <$>
 104                  [ Unicat_Symbol
 105                  , Unicat_Punctuation
 106                  , Unicat_Mark
 107                  ]) `but` koG
 108                 where
 109                 koG = choice (char <$> ['(', ')', '`', '\'', ',', '[', ']'])
 110         g_term_keysyms :: Reg rl g String
 111         g_term_keysyms = rule "term_keysyms" $
 112                 choice $ string <$> ["\\", "->", "=", "@"]
 113
 114 deriving instance Gram_Name g => Gram_Name (CF g)
 115 instance Gram_Name EBNF
 116 instance Gram_Name RuleEBNF
 117
 118 -- * Class 'Gram_Term_Type'
 119 class
 120  ( Gram_Terminal g
 121  , Gram_Rule g
 122  , Gram_Alt g
 123  , Gram_AltApp g
 124  , Gram_App g
 125  , Gram_CF g
 126  , Gram_Comment g
 127  , Gram_Name g
 128  , Gram_Type src g
 129  ) => Gram_Term_Type src g where
 130         g_term_abst_decl :: CF g (NameTe, AST_Type src)
 131         g_term_abst_decl = rule "term_abst_decl" $
 132                 parens $ (,)
 133                  <$> g_term_name
 134                  <*  (symbol "::" <+> symbol ":")
 135                  -- NOTE: "::" is Haskell compatibility and ":" is another common notation.
 136                  <*> g_type
 137
 138 deriving instance Gram_Term_Type src g => Gram_Term_Type src (CF g)
 139 instance Gram_Source src EBNF => Gram_Term_Type src EBNF
 140 instance Gram_Source src RuleEBNF => Gram_Term_Type src RuleEBNF
 141
 142 -- ** Type 'Error_Term_Gram'
 143 data Error_Term_Gram
 144  =   Error_Term_Gram_Fixity Error_Fixity
 145  |   Error_Term_Gram_Term_incomplete
 146  |   Error_Term_Gram_Type_applied_to_nothing
 147  |   Error_Term_Gram_not_applicable
 148  |   Error_Term_Gram_application
 149  |   Error_Term_Gram_application_mismatch
 150  |   Error_Term_Gram_Module Error_Module
 151  deriving (Eq, Show)
 152
 153 -- * Class 'Gram_Term'
 154 class
 155  ( Gram_Source src g
 156  , Gram_Error Error_Term_Gram g
 157  , Gram_Terminal g
 158  , Gram_Rule g
 159  , Gram_Alt g
 160  , Gram_App g
 161  , Gram_AltApp g
 162  , Gram_CF g
 163  , Gram_Comment g
 164  , Gram_Type src g
 165  , Gram_Name g
 166  , Gram_Term_Type src g
 167  , Gram_Term_Atoms src ss g
 168  , Gram_State (Imports, Modules src ss) g
 169  ) => Gram_Term src ss g where
 170         g_term :: CF g (AST_Term src ss)
 171         g_term = rule "term" $
 172                 choice
 173                  [ try g_term_abst
 174                  , g_term_operators
 175                  , g_term_let
 176                  ]
 177         g_term_operators :: CF g  (AST_Term src ss)
 178         g_term_operators = rule "term_operators" $
 179                 G.catch $
 180                 left Error_Term_Gram_Fixity <$>
 181                 g_ops
 182                 where
 183                 g_ops :: CF g (Either Error_Fixity  (AST_Term src ss))
 184                 g_ops = operators g_term_atom g_prefix g_infix g_postfix
 185                 g_prefix  :: CF g (Unifix, AST_Term src ss -> AST_Term src ss)
 186                 g_infix   :: CF g (Infix,  AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
 187                 g_postfix :: CF g (Unifix, AST_Term src ss -> AST_Term src ss)
 188                 g_prefix  = G.catch $ G.source $ G.getAfter $ op_prefix  <$> g_prefix_op
 189                 g_infix   = G.catch $ G.source $ G.getAfter $ op_infix   <$> g_infix_op
 190                 g_postfix = G.catch $ G.source $ G.getAfter $ op_postfix <$> g_postfix_op
 191                 op_infix
 192                  :: Mod NameTe
 193                  -> (Imports, Modules src ss)
 194                  -> src
 195                  -> Either Error_Term_Gram
 196                            (Infix, AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
 197                 op_infix name (imps, mods) src = do
 198                         t <- Error_Term_Gram_Module `left`
 199                                 lookupDefTerm FixitySing_Infix imps name mods
 200                         Right $ (token_fixity t,) $ \a b ->
 201                                 (BinTree0 (token_term t src) `BinTree2` a) `BinTree2` b
 202                 op_prefix, op_postfix
 203                  :: Mod NameTe
 204                  -> (Imports, Modules src ss)
 205                  -> src
 206                  -> Either Error_Term_Gram
 207                            ( Unifix
 208                            , AST_Term src ss -> AST_Term src ss )
 209                 op_prefix name (imps, mods) src = do
 210                         t <- Error_Term_Gram_Module `left`
 211                                 lookupDefTerm FixitySing_Prefix imps name mods
 212                         Right $ (token_fixity t,) $ \a ->
 213                                 BinTree0 (token_term t src) `BinTree2` a
 214                 op_postfix name (imps, mods) src = do
 215                         t <- Error_Term_Gram_Module `left`
 216                                 lookupDefTerm FixitySing_Postfix imps name mods
 217                         Right $ (token_fixity t,) $ \a ->
 218                                 BinTree0 (token_term t src) `BinTree2` a
 219                 g_postfix_op :: CF g (Mod NameTe)
 220                 g_postfix_op = rule "term_op_postfix" $
 221                         lexeme $
 222                                 g_backquote *> g_term_mod_idname <+> -- <* (G.cfOf $ Gram.Term (pure ' ') `but` g_backquote)
 223                                 g_term_mod_opname
 224                 g_infix_op :: CF g (Mod NameTe)
 225                 g_infix_op = rule "term_op_infix" $
 226                         lexeme $
 227                                 between g_backquote g_backquote g_term_mod_idname <+>
 228                                 try (Fun.const <$> g_term_mod_opname <*> (string " " <+> string "\n")) <+>
 229                                 pure (Mod [] " ")
 230                 g_prefix_op :: CF g (Mod NameTe)
 231                 g_prefix_op = rule "term_op_prefix" $
 232                         lexeme $
 233                                 g_term_mod_idname <* g_backquote <+>
 234                                 g_term_mod_opname
 235                 g_backquote :: Gram_Terminal g' => g' Char
 236                 g_backquote = char '`'
 237
 238         g_term_atom :: CF g  (AST_Term src ss)
 239         g_term_atom = rule "term_atom" $
 240                 choice $
 241                  {-(try (
 242                         G.source $
 243                         (\typ src -> BinTree0 $ inj_EToken src $ Token_Term_Type typ)
 244                          <$ char '@' <*> g_type) :) $
 245                  -}
 246                  (try <$> g_term_atomsR @_ @_ @ss) <>
 247                  [ try $
 248                         G.catch $ G.source $ G.getAfter $
 249                         (\m (imps, mods) src ->
 250                                 case lookupDefTerm FixitySing_Infix imps m mods of
 251                                  Right t -> Right $ BinTree0 $ token_term t src
 252                                  Left err ->
 253                                         case m of
 254                                          [] `Mod` n -> Right $ BinTree0 $ Token_Term_Var src n
 255                                          _ -> Left $ Error_Term_Gram_Module err
 256                          ) <$> g_term_mod_name
 257                  , g_term_group
 258                  ]
 259         g_term_group :: CF g (AST_Term src ss)
 260         g_term_group = rule "term_group" $ parens g_term
 261         g_term_abst :: CF g (AST_Term src ss)
 262         g_term_abst = rule "term_abst" $
 263                 G.source $
 264                 ((\(xs, te) src ->
 265                         foldr (\(x, ty_x) ->
 266                                 BinTree0 . Token_Term_Abst src x ty_x) te xs) <$>) $
 267                 g_term_abst_args_body
 268                  (symbol "\\" *> some g_term_abst_decl <* symbol "->")
 269                  g_term
 270         g_term_abst_args_body
 271          :: CF g [(NameTe, AST_Type src)]
 272          -> CF g (AST_Term src ss)
 273          -> CF g ([(NameTe, AST_Type src)], AST_Term src ss)
 274         -- g_term_abst_args_body args body = (,) <$> args <*> body
 275         g_term_abst_args_body cf_args cf_body =
 276                 G.stateBefore $
 277                 (\a b (imps::Imports, mods::Modules src ss) -> ((imps, mods), (a, b)))
 278                  <$> G.stateAfter ((<$> cf_args) $ \args (imps::Imports, Modules mods) ->
 279                         ((imps, Modules $ Map.alter (setArgs args) [] mods), args))
 280                  <*> cf_body
 281                 where
 282                 setArgs args = \case
 283                  Nothing -> Just $ moduleEmpty {module_infix = insArg mempty args}
 284                  Just mod -> Just $ mod
 285                          { module_prefix  = delArg (module_prefix  mod) args
 286                          , module_infix   = insArg (module_infix   mod) args
 287                          , module_postfix = delArg (module_postfix mod) args
 288                          }
 289                 delArg :: ModuleFixy src ss Unifix -> [(NameTe, _a)] -> ModuleFixy src ss Unifix
 290                 delArg = foldr $ \(n, _) -> Map.delete n
 291                 insArg :: ModuleFixy src ss Infix -> [(NameTe, _a)] -> ModuleFixy src ss Infix
 292                 insArg = foldr $ \(n, _) ->
 293                         Map.insert n Tokenizer
 294                          { token_term   = (`Token_Term_Var` n)
 295                          , token_fixity = infixN5
 296                          }
 297         g_term_let :: CF g  (AST_Term src ss)
 298         g_term_let = rule "term_let" $
 299                 G.source $
 300                 (\name args bound body src ->
 301                         BinTree0 $
 302                         Token_Term_Let src name
 303                          (foldr (\(x, ty_x) ->
 304                                 BinTree0 . Token_Term_Abst src x ty_x) bound args) body)
 305                  <$  symbol "let"
 306                  <*> g_term_name
 307                  <*> many g_term_abst_decl
 308                  <*  symbol "="
 309                  <*> g_term
 310                  <*  symbol "in"
 311                  <*> g_term
 312
 313 deriving instance
 314  ( Gram_Term src ss g
 315  , Gram_Term_Atoms src ss (CF g)
 316  ) => Gram_Term src ss (CF g)
 317 instance
 318  ( Gram_Term_Atoms src ss EBNF
 319  , Gram_Source src EBNF
 320  ) => Gram_Term src ss EBNF
 321 instance
 322  ( Gram_Term_Atoms src ss RuleEBNF
 323  , Gram_Source src RuleEBNF
 324  ) => Gram_Term src ss RuleEBNF
 325
 326 -- ** Class 'Gram_Term_Atoms'
 327 type Gram_Term_Atoms src ss g = Gram_Term_AtomsR src ss ss g
 328
 329 -- *** Class 'Gram_Term_AtomsR'
 330 class Gram_Term_AtomsR src (ss::[*]) (rs::[*]) g where
 331         g_term_atomsR :: [CF g (AST_Term src ss)]
 332 instance Gram_Term_AtomsR src ss '[] g where
 333         g_term_atomsR = []
 334 instance
 335  ( Gram_Term_AtomsFor src ss g t
 336  , Gram_Term_AtomsR src ss rs g
 337  ) => Gram_Term_AtomsR src ss (Proxy t ': rs) g where
 338         g_term_atomsR =
 339                 g_term_atomsFor @_ @_ @_ @t <>
 340                 g_term_atomsR @_ @_ @rs
 341
 342 -- *** Class 'Gram_Term_AtomsFor'
 343 class Gram_Term_AtomsFor src ss g t where
 344         g_term_atomsFor :: [CF g (AST_Term src ss)]
 345         g_term_atomsFor = []
 346
 347 gram_term
 348  :: forall g.
 349  ( Gram_Term () '[Proxy (->), Proxy Integer] g
 350  ) => [CF g ()]
 351 gram_term =
 352  [ voiD g_term
 353  , voiD g_term_operators
 354  , voiD g_term_atom
 355  , voiD g_term_group
 356  , voiD g_term_abst
 357  , void (g_term_abst_decl::CF g (NameTe, AST_Type ()))
 358  , voiD g_term_let
 359  , void g_term_mod_name
 360  , void g_term_name
 361  , void g_term_idname
 362  , void $ G.cfOf g_term_idname_tail
 363  , void $ G.cfOf g_term_keywords
 364  , void g_term_mod_opname
 365  , void g_term_opname
 366  , void $ G.cfOf g_term_opname_ok
 367  , void $ G.cfOf g_term_keysyms
 368  ] where
 369         voiD :: CF g (AST_Term () '[Proxy (->), Proxy Integer]) -> CF g ()
 370         voiD = (() <$)