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