symantic/Language/Symantic/Compiling/Grammar.hs

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