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 (mod, not, 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_Terminal 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_NameTeKey
  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_NameTeKey :: Reg rl g String
  67         g_NameTeKey = rule "NameTeKey" $
  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_NameTeKeySym
  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_NameTeKeySym :: Reg rl g String
  92         g_NameTeKeySym = rule "NameTeKeySym" $
  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_Terminal 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 "term_abst_decl" $
 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  , NameTyOf (->)
 123  , NameTyOf (,)
 124  , NameTyOf []
 125  ) => Gram_Term_Type src EBNF
 126 instance
 127  ( Gram_Source src RuleEBNF
 128  , NameTyOf (->)
 129  , NameTyOf (,)
 130  , NameTyOf []
 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_Terminal 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 "term_operators" $
 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_infix   :: CF g (Infix,  AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
 178                 g_postfix :: CF g (Unifix, AST_Term src ss -> AST_Term src ss)
 179                 g_prefix  = G.catch $ G.source $ G.getAfter $ op_prefix  <$> g_prefix_op
 180                 g_infix   = G.catch $ G.source $ G.getAfter $ op_infix   <$> g_infix_op
 181                 g_postfix = G.catch $ G.source $ G.getAfter $ op_postfix <$> g_postfix_op
 182                 op_infix
 183                  :: Mod NameTe
 184                  -> (Imports NameTe, Modules src ss)
 185                  -> src
 186                  -> Either Error_Term_Gram
 187                            (Infix, AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
 188                 op_infix name (imps, mods) src = do
 189                         t <- Error_Term_Gram_Module `left`
 190                                 lookupDefTerm FixyInfix imps name mods
 191                         Right $ (token_fixity t,) $ \a b ->
 192                                 (BinTree0 (token_term t src) `BinTree2` a) `BinTree2` b
 193                 op_prefix, op_postfix
 194                  :: Mod NameTe
 195                  -> (Imports NameTe, Modules src ss)
 196                  -> src
 197                  -> Either Error_Term_Gram
 198                            ( Unifix
 199                            , AST_Term src ss -> AST_Term src ss )
 200                 op_prefix name (imps, mods) src = do
 201                         t <- Error_Term_Gram_Module `left`
 202                                 lookupDefTerm FixyPrefix imps name mods
 203                         Right $ (token_fixity t,) $ \a ->
 204                                 BinTree0 (token_term t src) `BinTree2` a
 205                 op_postfix name (imps, mods) src = do
 206                         t <- Error_Term_Gram_Module `left`
 207                                 lookupDefTerm FixyPostfix imps name mods
 208                         Right $ (token_fixity t,) $ \a ->
 209                                 BinTree0 (token_term t src) `BinTree2` a
 210                 g_postfix_op :: CF g (Mod NameTe)
 211                 g_postfix_op = rule "term_op_postfix" $
 212                         lexeme $
 213                                 g_backquote *> g_ModNameTeId <+> -- <* (G.cfOf $ Gram.Term (pure ' ') `but` g_backquote)
 214                                 g_ModNameTeOp
 215                 g_infix_op :: CF g (Mod NameTe)
 216                 g_infix_op = rule "term_op_infix" $
 217                         lexeme $
 218                                 between g_backquote g_backquote g_ModNameTeId <+>
 219                                 try (Fun.const <$> g_ModNameTeOp <*> (string " " <+> string "\n")) <+>
 220                                 pure (Mod [] " ")
 221                 g_prefix_op :: CF g (Mod NameTe)
 222                 g_prefix_op = rule "term_op_prefix" $
 223                         lexeme $
 224                                 g_ModNameTeId <* g_backquote <+>
 225                                 g_ModNameTeOp
 226                 g_backquote :: Gram_Terminal g' => g' Char
 227                 g_backquote = char '`'
 228
 229         g_term_atom :: CF g  (AST_Term src ss)
 230         g_term_atom = rule "term_atom" $
 231                 choice $
 232                  {-(try (
 233                         G.source $
 234                         (\typ src -> BinTree0 $ inj_EToken src $ Token_Term_Type typ)
 235                          <$ char '@' <*> g_type) :) $
 236                  -}
 237                  (try <$> g_term_atomsR @_ @_ @ss) <>
 238                  [ try $
 239                         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 "term_group" $ parens g_term
 252         g_term_abst :: CF g (AST_Term src ss)
 253         g_term_abst = rule "term_abst" $
 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 "term_let" $
 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  , NameTyOf (->)
 320  , NameTyOf (,)
 321  , NameTyOf []
 322  ) => Gram_Term src ss EBNF
 323 instance
 324  ( Gram_Term_Atoms src ss RuleEBNF
 325  , Gram_Source src RuleEBNF
 326  , NameTyOf (->)
 327  , NameTyOf (,)
 328  , NameTyOf []
 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_NameTeKey
 369  , void g_ModNameTeOp
 370  , void g_NameTeOp
 371  , void $ G.cfOf g_NameTeOpOk
 372  , void $ G.cfOf g_NameTeKeySym
 373  ] where
 374         voiD :: CF g (AST_Term () '[Proxy (->), Proxy Integer]) -> CF g ()
 375         voiD = (() <$)