, module Language.Symantic.Grammar.Regular
, module Language.Symantic.Grammar.ContextFree
, module Language.Symantic.Grammar.Operators
- , module Language.Symantic.Grammar.Source
- , module Language.Symantic.Grammar.Error
+ , module Language.Symantic.Grammar.Meta
, module Language.Symantic.Grammar.BinTree
) where
import Language.Symantic.Grammar.Regular
import Language.Symantic.Grammar.ContextFree
import Language.Symantic.Grammar.Operators
-import Language.Symantic.Grammar.Source
-import Language.Symantic.Grammar.Error
+import Language.Symantic.Grammar.Meta
import Language.Symantic.Grammar.BinTree
import Data.String (IsString(..))
import Prelude hiding (any)
-import Language.Symantic.Grammar.Source
-import Language.Symantic.Grammar.Error
+import Language.Symantic.Grammar.Meta
import Language.Symantic.Grammar.Fixity
import Language.Symantic.Grammar.EBNF
import Language.Symantic.Grammar.Terminal
-- | Context-free grammar.
newtype CF g a = CF { unCF :: g a }
deriving (IsString, Functor, Gram_Terminal, Applicative, Gram_App)
-deriving instance Gram_Alt g => Gram_Alt (CF g)
-deriving instance Gram_Try g => Gram_Try (CF g)
+deriving instance Gram_Error err g => Gram_Error err (CF g)
+deriving instance Gram_Reader st g => Gram_Reader st (CF g)
+deriving instance Gram_State st g => Gram_State st (CF g)
+deriving instance Gram_Alt g => Gram_Alt (CF g)
+deriving instance Gram_Try g => Gram_Try (CF g)
deriving instance Gram_AltApp g => Gram_AltApp (CF g)
-deriving instance Gram_Rule g => Gram_Rule (CF g)
-deriving instance Gram_RegL g => Gram_RegL (CF g)
-deriving instance Gram_RegR g => Gram_RegR (CF g)
-deriving instance Gram_CF g => Gram_CF (CF g)
+deriving instance Gram_Rule g => Gram_Rule (CF g)
+deriving instance Gram_RegL g => Gram_RegL (CF g)
+deriving instance Gram_RegR g => Gram_RegR (CF g)
+deriving instance Gram_CF g => Gram_CF (CF g)
deriving instance Gram_CF RuleEBNF
deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (CF g)
instance Gram_CF EBNF where
CF $ EBNF $ \bo po -> parenInfix po op $
f bo (op, SideL) <> " - " <> g bo (op, SideR)
where op = infixL 6
-instance Gram_Meta meta g => Gram_Meta meta (CF g) where
- withMeta = CF . withMeta . unCF
-deriving instance Gram_Error err g => Gram_Error err (CF g)
cf_of_Terminal :: Terminal g a -> CF g a
cf_of_Terminal (Terminal g) = CF g
import Prelude hiding (any)
import qualified Data.Text as Text
-import Language.Symantic.Grammar.Source
-import Language.Symantic.Grammar.Error
+import Language.Symantic.Grammar.Meta
import Language.Symantic.Grammar.Fixity
-- * Type 'EBNF'
--
-- * 'Text' of the 'EBNF' rendition.
data EBNF a = EBNF { unEBNF :: RuleMode -> (Infix, Side) -> Text }
-instance Gram_Meta meta EBNF where
- withMeta (EBNF x) = EBNF x
+instance Gram_Reader st EBNF where
+ g_ask_before (EBNF e) = EBNF e
+ g_ask_after (EBNF e) = EBNF e
+instance Gram_State st EBNF where
+ g_state_before (EBNF e) = EBNF e
+ g_state_after (EBNF e) = EBNF e
instance Gram_Error err EBNF where
- catch (EBNF g) = EBNF g
+ g_catch (EBNF e) = EBNF e
-- | Get textual rendition of given 'EBNF'.
runEBNF :: EBNF a -> Text
newtype RuleEBNF a = RuleEBNF { unRuleEBNF :: EBNF a }
deriving (Functor, Applicative)
deriving instance Gram_RuleEBNF RuleEBNF
+deriving instance Gram_Error err RuleEBNF
+deriving instance Gram_Reader st RuleEBNF
+deriving instance Gram_State st RuleEBNF
instance Gram_Rule RuleEBNF where
rule n = ruleEBNF (ebnf_const n)
rule1 n g a = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a) (g a)
rule2 n g a b = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a `ebnf_arg` unRuleEBNF b) (g a b)
rule3 n g a b c = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a `ebnf_arg` unRuleEBNF b `ebnf_arg` unRuleEBNF c) (g a b c)
rule4 n g a b c d = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a `ebnf_arg` unRuleEBNF b `ebnf_arg` unRuleEBNF c `ebnf_arg` unRuleEBNF d) (g a b c d)
-instance Gram_Meta meta RuleEBNF where
- withMeta (RuleEBNF x) = RuleEBNF $ withMeta x
-- ** Class 'Gram_RuleEBNF'
-- | Symantics for rendering 'EBNF' rules.
, unEBNF body RuleMode_Ref (infixN0, SideR)
, ";"
]
-deriving instance Gram_Error err RuleEBNF
+++ /dev/null
-{-# LANGUAGE TypeApplications #-}
--- | Error handling utilities.
-module Language.Symantic.Grammar.Error where
-
-import Data.Proxy (Proxy(..))
-
--- * Class 'Gram_Error'
--- | Symantics for handling errors at the semantic level (not the syntaxic one).
-class Gram_Error err g where
- catch :: g (Either err a) -> g a
-
--- * Class 'Inj_Error'
-class Inj_Error a b where
- inj_Error :: a -> b
-instance Inj_Error err e => Inj_Error err (Either e a) where
- inj_Error = Left . inj_Error
-
-lift_Error ::
- forall e0 err e1 a.
- Inj_Error e0 e1 =>
- Inj_Error e1 err =>
- Proxy e1 -> Either e0 a -> Either err a
-lift_Error _e1 (Right a) = Right a
-lift_Error _e1 (Left e) = Left $ inj_Error @e1 @err $ inj_Error @e0 @e1 e
--- /dev/null
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Language.Symantic.Grammar.Meta where
+
+import Data.Proxy (Proxy(..))
+import Data.Typeable (Typeable)
+
+-- * Type 'Gram_Reader'
+class Gram_Reader st g where
+ g_ask_before :: g (st -> a) -> g a
+ g_ask_after :: g (st -> a) -> g a
+
+-- * Type 'Gram_State'
+class Gram_State st g where
+ g_state_before :: g (st -> (st, a)) -> g a
+ g_state_after :: g (st -> (st, a)) -> g a
+ g_get_before :: g (st -> a) -> g a
+ g_get_after :: g (st -> a) -> g a
+ g_put :: g (st, a) -> g a
+ default g_get_before :: Functor g => g (st -> a) -> g a
+ default g_get_after :: Functor g => g (st -> a) -> g a
+ default g_put :: Functor g => g (st, a) -> g a
+ g_get_before g = g_state_before ((\f -> \st -> (st, f st)) <$> g)
+ g_get_after g = g_state_after ((\f -> \st -> (st, f st)) <$> g)
+ g_put g = g_state_after ((\(st, a) -> \_st -> (st, a)) <$> g)
+
+-- * Class 'Gram_Error'
+-- | Symantics for handling errors at the semantic level (not the syntaxic one).
+class Gram_Error err g where
+ g_catch :: g (Either err a) -> g a
+
+-- * Class 'Inj_Error'
+class Inj_Error a b where
+ inj_Error :: a -> b
+instance Inj_Error err e => Inj_Error err (Either e a) where
+ inj_Error = Left . inj_Error
+
+lift_Error ::
+ forall e0 err e1 a.
+ Inj_Error e0 e1 =>
+ Inj_Error e1 err =>
+ Proxy e1 -> Either e0 a -> Either err a
+lift_Error _e1 (Right a) = Right a
+lift_Error _e1 (Left e) = Left $ inj_Error @e1 @err $ inj_Error @e0 @e1 e
+
+-- * Class 'Source'
+class Source src where
+ noSource :: src
+instance Source () where
+ noSource = ()
+
+-- ** Class 'Inj_Source'
+class Source src => Inj_Source a src where
+ inj_Source :: a -> src
+instance Inj_Source a () where
+ inj_Source _ = ()
+
+-- ** Type family 'SourceOf'
+type family SourceOf a
+
+-- ** Type 'Sourced'
+class Source (SourceOf a) => Sourced a where
+ sourceOf :: a -> SourceOf a
+ setSource :: a -> SourceOf a -> a
+infixl 5 `setSource`
+
+source :: Inj_Source src (SourceOf a) => Sourced a => a -> src -> a
+source a src = a `setSource` inj_Source src
+
+-- ** Type 'Source_Input'
+type family Source_Input (src :: *) :: *
+type instance Source_Input () = ()
+
+-- ** Type 'Span'
+data Span src
+ = Span
+ { spanBegin :: !src
+ , spanEnd :: !src
+ } deriving (Eq, Ord, Show, Typeable)
+
+-- ** Class 'Gram_Source'
+class
+ ( Gram_Reader (Source_Input src) g
+ , Inj_Source (Span (Source_Input src)) src
+ ) => Gram_Source src g where
+ g_source :: Functor g => g (src -> a) -> g a
+ g_source g =
+ g_ask_after $ g_ask_before $
+ (\f (beg::Source_Input src) (end::Source_Input src) ->
+ f (inj_Source $ Span beg end::src))
+ <$> g
+instance
+ ( Gram_Reader (Source_Input src) g
+ , Inj_Source (Span (Source_Input src)) src
+ ) => Gram_Source src g
+
+-- ** Type 'At'
+-- | Attach a 'Source' to something.
+data At src a
+ = At
+ { at :: !src
+ , unAt :: !a
+ } deriving (Eq, Functor, Ord, Show, Typeable)
import Data.String (IsString(..))
import qualified Data.Text as Text
-import Language.Symantic.Grammar.Error
+import Language.Symantic.Grammar.Meta
import Language.Symantic.Grammar.Fixity
import Language.Symantic.Grammar.EBNF
import Language.Symantic.Grammar.Terminal
deriving instance Gram_Alt g => Gram_Alt (Reg lr g)
deriving instance Gram_Try g => Gram_Try (Reg lr g)
deriving instance Gram_Rule g => Gram_Rule (Reg lr g)
+deriving instance Gram_Reader st g => Gram_Reader st (Reg lr g)
+deriving instance Gram_State st g => Gram_State st (Reg lr g)
deriving instance Gram_Error err g => Gram_Error err (Reg lr g)
deriving instance (Functor g, Gram_Alt g, Gram_RegL g) => Gram_RegL (RegL g)
deriving instance (Functor g, Gram_Alt g, Gram_RegR g) => Gram_RegR (RegR g)
+++ /dev/null
-{-# LANGUAGE TypeFamilies #-}
-module Language.Symantic.Grammar.Source where
-
--- * Class 'Gram_Meta'
--- | Symantics for including metadata
--- (like the position in the input)
--- in the result of a grammar.
-class Gram_Meta meta g where
- withMeta :: g (meta -> a) -> g a
-
--- * Class 'Source'
-class Source src where
- noSource :: src
-instance Source () where
- noSource = ()
-
--- * Class 'Inj_Source'
-class Source src => Inj_Source a src where
- inj_Source :: a -> src
-instance Inj_Source a () where
- inj_Source _ = ()
-
--- ** Type family 'SourceOf'
-type family SourceOf a
-
--- ** Type 'Sourced'
-class Source (SourceOf a) => Sourced a where
- sourceOf :: a -> SourceOf a
- setSource :: a -> SourceOf a -> a
-infixl 5 `setSource`
-
-source :: (Inj_Source src (SourceOf a), Sourced a) => a -> src -> a
-source a src = a `setSource` inj_Source src
-
--- ** Type 'Text_of_Source'
-type family Text_of_Source (src :: *) :: *
-type instance Text_of_Source () = ()
-
-withSource ::
- forall src g a.
- Gram_Meta (Text_of_Source src) g =>
- Inj_Source (Text_of_Source src) src =>
- Functor g =>
- g (src -> a) -> g a
-withSource g = withMeta $ (\f (txt :: Text_of_Source src) -> f (inj_Source txt :: src)) <$> g
-
--- * Type 'At'
--- | Attach a source.
-data At src a
- = At src a
- deriving (Eq, Show)
-
-instance Functor (At src) where
- fmap f (At src a) = At src (f a)
-unAt :: At src a -> a
-unAt (At _ a) = a
Language.Symantic.Grammar.BinTree
Language.Symantic.Grammar.ContextFree
Language.Symantic.Grammar.EBNF
- Language.Symantic.Grammar.Error
Language.Symantic.Grammar.Fixity
+ Language.Symantic.Grammar.Meta
Language.Symantic.Grammar.Operators
Language.Symantic.Grammar.Regular
- Language.Symantic.Grammar.Source
Language.Symantic.Grammar.Terminal
build-depends:
base >= 4.6 && < 5
import Language.Symantic
import qualified Language.Symantic.Grammar as Gram
-import Grammar.MegaParsec
+import Grammar.Megaparsec
import Typing.Test ()
-- P.ParsecT instances
type instance MC.CanDo (P.ParsecT e s m) eff = 'False
instance ParsecC e s => Gram_Name (P.ParsecT e s m)
-instance ParsecC e s => Gram.Gram_Meta () (P.ParsecT e s m) where
- withMeta = (($ ()) <$>)
+-- instance ParsecC e s => Gram.Gram_Meta () (P.ParsecT e s m) where
+-- withMeta = (($ ()) <$>)
instance
( ParsecC e s
- , Gram.Gram_Meta (Gram.Text_of_Source src) (P.ParsecT e s m)
- , Gram.Gram_Meta src (P.ParsecT e s m)
- , Inj_Source (Gram.Text_of_Source src) src
+ , Gram.Gram_Source src (P.ParsecT e s m)
) => Gram_Term_Type src (P.ParsecT e s m)
instance ParsecC e s => Gram.Gram_Error (Error_Term_Gram) (P.ParsecT e s m) where
- catch me = do
+ g_catch me = do
e <- me
case e of
Left err -> fail $ show err
( ParsecC e s
, Source src, Show src
) => Gram.Gram_Error (Error_Term src) (P.ParsecT e s m) where
- catch me = do
+ g_catch me = do
e <- me
case e of
Left err -> fail $ show err
Right a -> return a
instance
( ParsecC e s
- , Show src
- , Gram.Gram_Meta (Gram.Text_of_Source src) (P.ParsecT e s m)
- , Gram.Gram_Meta src (P.ParsecT e s m)
- , Gram_Term_Atoms src ss (P.ParsecT e s m)
+ , Gram.Gram_Source src (P.ParsecT e s m)
, Gram.Gram_Error Error_Term_Gram (P.ParsecT e s m)
- , MC.MonadState (Modules src ss) m
- , Inj_Source (Gram.Text_of_Source src) src
- ) => Gram_Term src ss (P.ParsecT e s m) where
- modules_get (Gram.CF g) = Gram.CF $ do
- toks <- MC.get
- f <- g
- return $ f toks
- modules_put (Gram.CF g) = Gram.CF $ do
- (toks, a) <- g
- () <- MC.put toks
- return a
+ , Gram_Term_Atoms src ss (P.ParsecT e s m)
+ , Gram_State (Modules src ss) (P.ParsecT e s m)
+ ) => Gram_Term src ss (P.ParsecT e s m)
test_modules ::
forall ss src.
Either (P.ParseError Char P.Dec) (AST_Term src ss)
test_modules inp =
runIdentity $
- MC.evalStateStrict (inj_modules::Modules src ss) $
+ MC.evalStateStrict (inj_Modules::Modules src ss) $
P.runParserT g "" inp
where g = Gram.unCF $ g_term <* Gram.eoi
Left err -> Left (Left err) @?= snd `left` expected
Right ast ->
let tys = inj_Name2Type (Proxy @ss) in
- case readTe tys ast CtxTyZ of
+ case readTe tys CtxTyZ ast of
Left err -> Left (Right err) @?= snd `left` expected
Right term ->
case term of
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Grammar.MegaParsec where
+module Grammar.Megaparsec where
import Control.Applicative (Applicative(..))
+import Data.List.NonEmpty (NonEmpty)
import Data.String (IsString(..))
import Prelude hiding (any, (^), exp)
import qualified Control.Applicative as Alt
+import qualified Control.Monad.Classes as MC
import qualified Data.Char as Char
import qualified Data.Text as Text
import qualified Text.Megaparsec as P
CF f <& Reg p = CF $ P.lookAhead f <*> p
Reg f &> CF p = CF $ P.lookAhead f <*> p
minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
-instance ParsecC e s => Gram_Meta P.SourcePos (P.ParsecT e s m) where
- withMeta p = do
- pos <- P.getPosition
- ($ pos) <$> p
instance ParsecC e s => Gram_Comment (P.ParsecT e s m)
instance ParsecC e s => Gram_Op (P.ParsecT e s m)
+
+type instance MC.CanDo (P.ParsecT e s m) (MC.EffState st) = 'False
+instance ParsecC e s => Gram_Reader (NonEmpty P.SourcePos) (P.ParsecT e s m) where
+ g_ask_before g = do
+ s <- P.statePos <$> P.getParserState
+ f <- g
+ return (f s)
+ g_ask_after g = do
+ f <- g
+ s <- P.statePos <$> P.getParserState
+ return (f s)
+instance ParsecC e s => Gram_Reader () (P.ParsecT e s m) where
+ g_ask_before = fmap ($ ())
+ g_ask_after = fmap ($ ())
+instance (Monad m, MC.MonadState st m) => Gram_State st m where
+ g_state_before g = do
+ s <- MC.get
+ f <- g
+ let (s', a) = f s
+ MC.put s'
+ return a
+ g_state_after g = do
+ f <- g
+ s <- MC.get
+ let (s', a) = f s
+ MC.put s'
+ return a
+ g_get_before g = do
+ s <- MC.get
+ f <- g
+ return (f s)
+ g_get_after g = do
+ f <- g
+ s <- MC.get
+ return (f s)
+ g_put g = do
+ (s, a) <- g
+ MC.put s
+ return a
-- Compiling
instance
- ( Gram_Alt g
+ ( Gram_Source src g
+ , Gram_Alt g
, Gram_Rule g
, Gram_Comment g
- , Gram_Meta src g
, Inj_Sym ss Char
- , Source src
) => Gram_Term_AtomsFor src ss g Char where
g_term_atomsFor _t =
[ rule "teChar" $
- lexeme $ withMeta $
+ lexeme $ g_source $
(\c src -> BinTree0 $ Token_Term $ TermVT_CF $ (`setSource` src) $ teChar c)
<$> between tickG tickG (
cf_of_Terminal (Gram.any `but` tickG) <+>
-- Compiling
instance
- ( Gram_Alt g
+ ( Gram_Source src g
+ , Gram_Alt g
, Gram_AltApp g
, Gram_Rule g
, Gram_Comment g
- , Gram_Meta src g
, Inj_Sym ss Integer
- , Source src
) => Gram_Term_AtomsFor src ss g Integer where
g_term_atomsFor _t =
[ rule "teinteger" $
- lexeme $ withMeta $
+ lexeme $ g_source $
(\i src -> BinTree0 $ Token_Term $ TermVT_CF $ (`setSource` src) $ teInteger $ read i)
<$> some (choice $ char <$> ['0'..'9'])
]
[ rule "teList_list" $
between (symbol "[") (symbol "]") listG
, rule "teList_empty" $
- withMeta $
+ g_source $
(\src -> BinTree0 $ Token_Term $ TermVT_CF teList_empty `setSource` src)
<$ symbol "["
<* symbol "]"
where
listG :: CF g (AST_Term src ss)
listG = rule "list" $
- withMeta $
+ g_source $
(\a mb src ->
case mb of
- Just b_ -> BinTree2 (BinTree2 (BinTree0 $ Token_Term $ TermVT_CF $ (`setSource` src) $ teList_cons) a) b_
+ Just b -> BinTree2 (BinTree2 (BinTree0 $ Token_Term $ TermVT_CF $ (`setSource` src) $ teList_cons) a) b
Nothing ->
BinTree2
(BinTree2 (BinTree0 $ Token_Term $ TermVT_CF $ (`setSource` src) $ teList_cons) a)
-- Compiling
instance
- ( Gram_Alt g
+ ( Gram_Source src g
+ , Gram_Alt g
, Gram_Rule g
, Gram_Comment g
- , Gram_Meta src g
, Gram_Term src ss g
, Inj_Sym ss (,)
) => Gram_Term_AtomsFor src ss g (,) where
g_term_atomsFor _t =
-- TODO: proper TupleSections
[ rule "teTuple2_2" $
- withMeta $ parens $
+ g_source $ parens $
(\a b src ->
BinTree2 (BinTree2 (BinTree0 $ Token_Term $ TermVT_CF $ (`setSource` src) $ teTuple2) a) b)
<$> g_term
<* symbol ","
<*> g_term
, rule "teTuple2" $
- withMeta $
+ g_source $
(\src -> BinTree0 $ Token_Term $ TermVT_CF $ (`setSource` src) $ teTuple2)
<$ symbol "(,)"
]
-- Compiling
instance
- ( Gram_Rule g
+ ( Gram_Source src g
+ , Gram_Rule g
, Gram_Comment g
- , Gram_Meta src g
, Inj_Sym ss ()
- , Source src
) => Gram_Term_AtomsFor src ss g () where
g_term_atomsFor _t =
[ rule "teUnit" $
- withMeta $
+ g_source $
(\src -> BinTree0 $ Token_Term $ TermVT_CF $ (`setSource` src) $ teUnit)
<$ symbol "("
<* symbol ")"
import Data.Proxy
import Data.Ratio (Ratio)
import Data.Text (Text)
+import Data.List.NonEmpty (NonEmpty)
import GHC.Exts (Constraint)
import Prelude hiding (exp)
import qualified Data.Function as Fun
import Language.Symantic
import Language.Symantic.Lib hiding ((<$>), (<*), show)
-import Grammar.MegaParsec
+import Grammar.Megaparsec
-- * Tests
type SS =
, Proxy Show
, Proxy Traversable
]
-type SRC = SrcTe P.SourcePos SS
+type SRC = SrcTe (NonEmpty P.SourcePos) SS
instance
( ParsecC e s
- , Gram_Meta (Text_of_Source src) (P.ParsecT e s m)
- , Inj_Source (Text_of_Source src) src
+ , Gram_Source src (P.ParsecT e s m)
) => Gram_Type src (P.ParsecT e s m)
cs :: Source src => Name2Type src
main-is: Test.hs
other-modules:
Compiling.Test
- Grammar.MegaParsec
+ Grammar.Megaparsec
Lib.Applicative.Test
Lib.Bool.Test
Lib.Foldable.Test
, module Language.Symantic.Transforming
-- * Re-exports for convenience.
, module Language.Symantic.Grammar.Fixity
- , module Language.Symantic.Grammar.Source
- , module Language.Symantic.Grammar.Error
+ , module Language.Symantic.Grammar.Meta
) where
import Language.Symantic.Typing
import Language.Symantic.Transforming
import Language.Symantic.Grammar.Fixity
-import Language.Symantic.Grammar.Source
-import Language.Symantic.Grammar.Error
+import Language.Symantic.Grammar.Meta
type Inj_Modules src ss
= Inj_ModulesR src ss ss
-inj_modules :: forall src ss. Inj_Modules src ss => Modules src ss
-inj_modules = inj_modulesR (Proxy @ss)
+inj_Modules :: forall src ss. Inj_Modules src ss => Modules src ss
+inj_Modules = inj_ModulesR (Proxy @ss)
-- ** Class 'Inj_ModulesR'
class Inj_ModulesR src (ss::[*]) (rs::[*]) where
- inj_modulesR :: Proxy rs -> Modules src ss
+ inj_ModulesR :: Proxy rs -> Modules src ss
instance Inj_ModulesR src ss '[] where
- inj_modulesR _rs = mempty
+ inj_ModulesR _rs = mempty
instance
( Module src ss s
, Inj_ModulesR src ss rs
) => Inj_ModulesR src ss (Proxy s ': rs) where
- inj_modulesR _ = inj_modulesR (Proxy @rs) <> module_ (Proxy @s)
+ inj_ModulesR _ = inj_ModulesR (Proxy @rs) <> module_ (Proxy @s)
-- | Lookup the given 'Mod' 'NameTe' into the given 'Modules',
-- returning for prefix, infix and postfix positions, when there is a match.
class
( Gram_Terminal g
, Gram_Rule g
- , Gram_Meta src g
, Gram_Alt g
, Gram_AltApp g
, Gram_App g
<*> g_type
deriving instance Gram_Term_Type src g => Gram_Term_Type src (CF g)
-instance Inj_Source (Text_of_Source src) src => Gram_Term_Type src EBNF
-instance Inj_Source (Text_of_Source src) src => Gram_Term_Type src RuleEBNF
+instance Gram_Source src EBNF => Gram_Term_Type src EBNF
+instance Gram_Source src RuleEBNF => Gram_Term_Type src RuleEBNF
-- ** Type 'Error_Term_Gram'
data Error_Term_Gram
-- * Class 'Gram_Term'
class
- ( Gram_Meta src g
+ ( Gram_Source src g
, Gram_Error Error_Term_Gram g
, Gram_Terminal g
, Gram_Rule g
, Gram_Name g
, Gram_Term_Type src g
, Gram_Term_Atoms src ss g
- , Show src
+ , Gram_State (Modules src ss) g
) => Gram_Term src ss g where
- modules_get :: CF g (Modules src ss -> a) -> CF g a
- modules_put :: CF g (Modules src ss, a) -> CF g a
- g_term :: CF g (AST_Term src ss)
+ -- getModules :: CF g (Modules src ss -> a) -> CF g a
+ -- setModules :: CF g (Modules src ss, a) -> CF g a
+ g_term :: CF g (AST_Term src ss)
g_term = rule "term" $
choice
[ try g_term_abst
]
g_term_operators :: CF g (AST_Term src ss)
g_term_operators = rule "term_operators" $
- catch $
+ g_catch $
left Error_Term_Gram_Fixity <$>
g_ops
where
g_prefix :: CF g (Unifix, AST_Term src ss -> AST_Term src ss)
g_infix :: CF g (Infix, AST_Term src ss -> AST_Term src ss -> AST_Term src ss)
g_postfix :: CF g (Unifix, AST_Term src ss -> AST_Term src ss)
- g_prefix = catch $ withMeta $ modules_get $ op_prefix <$> g_prefix_op
- g_infix = catch $ withMeta $ modules_get $ op_infix <$> g_infix_op
- g_postfix = catch $ withMeta $ modules_get $ op_postfix <$> g_postfix_op
+ g_prefix = g_catch $ g_source $ g_get_after $ op_prefix <$> g_prefix_op
+ g_infix = g_catch $ g_source $ g_get_after $ op_infix <$> g_infix_op
+ g_postfix = g_catch $ g_source $ g_get_after $ op_postfix <$> g_postfix_op
op_infix
:: Mod NameTe
-> Modules src ss
g_term_atom = rule "term_atom" $
choice $
{-(try (
- withMeta $
+ g_source $
(\typ src -> BinTree0 $ inj_EToken src $ Token_Term_Type typ)
<$ char '@' <*> g_type) :) $
-}
(try <$> g_term_atomsR (Proxy @ss)) <>
[ try $
- catch $ withMeta $ modules_get $
+ g_catch $ g_source $ g_get_after $
(\mn toks src -> do
let (_, in_, _) = modulesLookup mn toks
case in_ of
g_term_group = rule "term_group" $ parens g_term
g_term_abst :: CF g (AST_Term src ss)
g_term_abst = rule "term_abst" $
- withMeta $
+ g_source $
((\(xs, te) src ->
foldr (\(x, ty_x) ->
BinTree0 . Token_Term_Abst src x ty_x) te xs) <$>) $
g_term
g_term_abst_args_body
:: CF g [(NameTe, AST_Type src)]
- -> CF g (AST_Term src ss)
+ -> CF g (AST_Term src ss)
-> CF g ([(NameTe, AST_Type src)], AST_Term src ss)
-- g_term_abst_args_body args body = (,) <$> args <*> body
g_term_abst_args_body cf_args cf_body =
- modules_put $ modules_get $
+ g_state_before $
(\a b (toks::Modules src ss) -> (toks, (a, b)))
- <$> (modules_put $ modules_get $
+ <$> (g_state_after $
(\args (toks::Modules src ss) -> (,args)
Modules
{ modules_prefix = del (modules_prefix toks) args
}
g_term_let :: CF g (AST_Term src ss)
g_term_let = rule "term_let" $
- withMeta $
+ g_source $
(\name args bound body src ->
BinTree0 $
Token_Term_Let src name
deriving instance
( Gram_Term src ss g
, Gram_Term_Atoms src ss (CF g)
- , Show src
) => Gram_Term src ss (CF g)
instance
( Gram_Term_Atoms src ss EBNF
- , Inj_Source (Text_of_Source src) src
- , Show src
- ) => Gram_Term src ss EBNF where
- modules_get (CF (EBNF g)) = CF $ EBNF g
- modules_put (CF (EBNF g)) = CF $ EBNF g
+ , Gram_Source src EBNF
+ ) => Gram_Term src ss EBNF
instance
( Gram_Term_Atoms src ss RuleEBNF
- , Inj_Source (Text_of_Source src) src
- , Show src
- ) => Gram_Term src ss RuleEBNF where
- modules_get (CF (RuleEBNF (EBNF g))) = CF $ RuleEBNF $ EBNF g
- modules_put (CF (RuleEBNF (EBNF g))) = CF $ RuleEBNF $ EBNF g
+ , Gram_Source src RuleEBNF
+ ) => Gram_Term src ss RuleEBNF
-- ** Class 'Gram_Term_Atoms'
type Gram_Term_Atoms src ss g = Gram_Term_AtomsR src ss ss g
Inj_Source (AST_Type src) src =>
Constable (->) =>
Name2Type src ->
- AST_Term src ss ->
CtxTy src ts ->
+ AST_Term src ss ->
Either (Error_Term src) (TermVT src ss ts)
-readTe cs ast ctxTe = do
+readTe cs ctxTe ast = do
ts <- go ctxTe `traverse` ast
inj_Error `left` betasTe ts
where
case lenVars ty_arg of
LenS{} -> Left $ Error_Term_polymorphic $ TypeVT ty_arg
LenZ | (TypeK qa, TypeK ta) <- unQualTy ty_arg -> do
- TermVT (Term qr tr (TeSym res)) <- readTe cs ast_body (CtxTyS name_arg ta ts)
+ TermVT (Term qr tr (TeSym res)) <- readTe cs (CtxTyS name_arg ta ts) ast_body
let (qa', qr') = appendVars qa qr
let (ta', tr') = appendVars ta tr
Right $ TermVT $ Term @_ @_ @_ @_ @(_ #> _) (qa' # qr') (ta' ~> tr') $
TeSym $ \c -> lam $ \arg -> res (arg `CtxTeS` c)
go ts (Token_Term_Let _src name ast_arg ast_body) = do
- TermVT (Term qa ta (TeSym arg)) <- readTe cs ast_arg ts
+ TermVT (Term qa ta (TeSym arg)) <- readTe cs ts ast_arg
case lenVars ta of
LenS{} -> Left $ Error_Term_polymorphic $ TypeVT (qa #> ta)
LenZ -> do
- TermVT (Term qr tr (TeSym res)) <- readTe cs ast_body $ CtxTyS name ta ts
+ TermVT (Term qr tr (TeSym res)) <- readTe cs (CtxTyS name ta ts) ast_body
let (qa', qr') = appendVars qa qr
let tr' = allocVarsL (lenVars ta) tr
Right $ TermVT $ Term @_ @_ @_ @_ @(_ #> _) (qa' # qr') tr' $
inj_Error = Error_Term_Type . inj_Error
-- * Type 'SrcTe'
-data SrcTe txt ss
+data SrcTe inp ss
= SrcTe_Less
- | SrcTe_Text txt
- | SrcTe_AST_Term (AST_Term (SrcTe txt ss) ss)
- | SrcTe_AST_Type (AST_Type (SrcTe txt ss))
- | SrcTe_Kind (KindK (SrcTe txt ss))
- | SrcTe_Type (TypeVT (SrcTe txt ss))
+ | SrcTe_Input (Span inp)
+ | SrcTe_AST_Term (AST_Term (SrcTe inp ss) ss)
+ | SrcTe_AST_Type (AST_Type (SrcTe inp ss))
+ | SrcTe_Kind (KindK (SrcTe inp ss))
+ | SrcTe_Type (TypeVT (SrcTe inp ss))
| SrcTe_Term
deriving (Eq, Show)
-type instance Text_of_Source (SrcTe txt ss) = txt
+type instance Source_Input (SrcTe inp ss) = inp
-instance Source (SrcTe txt ss) where
+instance Source (SrcTe inp ss) where
noSource = SrcTe_Less
-instance Inj_Source txt (SrcTe txt ss) where
- inj_Source = SrcTe_Text
-instance Inj_Source (AST_Term (SrcTe txt ss) ss) (SrcTe txt ss) where
+instance Inj_Source (Span inp) (SrcTe inp ss) where
+ inj_Source = SrcTe_Input
+instance Inj_Source (AST_Term (SrcTe inp ss) ss) (SrcTe inp ss) where
inj_Source = SrcTe_AST_Term
-instance Inj_Source (AST_Type (SrcTe txt ss)) (SrcTe txt ss) where
+instance Inj_Source (AST_Type (SrcTe inp ss)) (SrcTe inp ss) where
inj_Source = SrcTe_AST_Type
-instance Inj_Source (KindK (SrcTe txt ss)) (SrcTe txt ss) where
+instance Inj_Source (KindK (SrcTe inp ss)) (SrcTe inp ss) where
inj_Source = SrcTe_Kind
-instance Inj_Source (TypeVT (SrcTe txt ss)) (SrcTe txt ss) where
+instance Inj_Source (TypeVT (SrcTe inp ss)) (SrcTe inp ss) where
inj_Source = SrcTe_Type
-- * Class 'Gram_Type'
-- | Read an 'AST_Type' from a textual source.
class
- ( Gram_Terminal g
+ ( Gram_Source src g
+ , Gram_Terminal g
, Gram_Rule g
, Gram_Alt g
, Gram_Try g
, Gram_CF g
, Gram_Comment g
, Gram_Op g
- , Gram_Meta (Text_of_Source src) g
- , Inj_Source (Text_of_Source src) src
) => Gram_Type src g where
g_type :: CF g (AST_Type src)
g_type = rule "type" $ g_type_fun
g_type_fun :: CF g (AST_Type src)
g_type_fun = rule "type_fun" $
- infixrG g_type_list (withSource $ op <$ symbol "->")
+ infixrG g_type_list (g_source $ op <$ symbol "->")
where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src "(->)")
-- TODO: maybe not harcoding g_type_list and g_type_tuple2
g_type_list :: CF g (AST_Type src)
g_type_list = rule "type_list" $
- withSource $ inside mk
+ g_source $ inside mk
(symbol "[") (optional g_type) (symbol "]")
(const <$> g_type_tuple2)
where
tok src = BinTree0 $ Token_Type_Const $ At src "[]"
g_type_tuple2 :: CF g (AST_Type src)
g_type_tuple2 = rule "type_tuple2" $
- try (parens (infixrG (g_type) (withSource $ op <$ symbol ","))) <+> (g_type_app)
+ try (parens (infixrG (g_type) (g_source $ op <$ symbol ","))) <+> (g_type_app)
where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ At src "(,)")
g_type_app :: CF g (AST_Type src)
g_type_app = rule "type_app" $
g_type_symbol
g_type_name_const :: CF g (AST_Type src)
g_type_name_const = rule "type_name_const" $
- lexeme $ withSource $
+ lexeme $ g_source $
(\n ns src -> BinTree0 $ Token_Type_Const $ At src $ fromString $ n:ns)
<$> unicat (Unicat Char.UppercaseLetter)
<*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
g_type_name_var :: CF g (AST_Type src)
g_type_name_var = rule "type_name_var" $
- lexeme $ withSource $
+ lexeme $ g_source $
(\n ns src -> BinTree0 $ Token_Type_Var $ At src $ fromString $ n:ns)
<$> unicat (Unicat Char.LowercaseLetter)
<*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
g_type_symbol :: CF g (AST_Type src)
g_type_symbol = rule "type_symbol" $
- withSource $ (mk <$>) $
+ g_source $ (mk <$>) $
parens $ many $ cf_of_Terminal $ choice g_ok `but` choice g_ko
where
mk s src = BinTree0 $ Token_Type_Const $ At src (fromString $ "(" ++ s ++ ")")
g_ko = char <$> ['(', ')', '`']
deriving instance Gram_Type src g => Gram_Type src (CF g)
-instance Inj_Source (Text_of_Source src) src => Gram_Type src EBNF
-instance Inj_Source (Text_of_Source src) src => Gram_Type src RuleEBNF
+instance Gram_Source src EBNF => Gram_Type src EBNF
+instance Gram_Source src RuleEBNF => Gram_Type src RuleEBNF
-- | List of the rules of 'Gram_Type'.
gram_type :: Gram_Type () g => [CF g (AST_Type ())]
sourcephile / git / haskell / symantic.git / commitdiff