use_flake() {
watch_file flake.nix
watch_file flake.lock
+ watch_file default.nix
+ watch_file shell.nix
mkdir -p "$(direnv_layout_dir)"
- eval "$(nix print-dev-env --option allow-import-from-derivation true -L --show-trace --impure --profile "$(direnv_layout_dir)/flake-profile" || echo false)" &&
+ eval "$(nix print-dev-env --option allow-import-from-derivation true -L --show-trace --profile "$(direnv_layout_dir)/flake-profile" || echo false)" &&
nix-store --add-root "shell.root" \
--indirect --realise "$(direnv_layout_dir)/flake-profile"
}
{ pkgs ? import <nixpkgs> {}
-, ghc ? null # "ghc8102"
+, ghc ? "ghc901"
, withHoogle ? false
}:
let
sha256 = "sha256-I636Kl+S93BDX1xrEMQdf217pLeT6FeF4BBpj83sEgQ=";
}) {};
*/
+ # Relax upper bound to support ghc-9.0.1
+ bifunctors = doJailbreak hsuper.bifunctors;
+ attoparsec = doJailbreak hsuper.attoparsec;
+ assoc = doJailbreak hsuper.assoc;
+ vector-binary-instances = doJailbreak hsuper.vector-binary-instances;
+ vector-th-unbox = doJailbreak hsuper.vector-th-unbox;
+ these = doJailbreak hsuper.these;
+ quickcheck-instances = doJailbreak hsuper.quickcheck-instances;
+ binary-orphans = doJailbreak hsuper.binary-orphans;
+ text-short = doJailbreak hsuper.text-short;
+ aeson = doJailbreak hsuper.aeson;
symantic-parser = enableExecutableProfiling (doCheck (
hself.callCabal2nix "symantic-parser" ./. {}));
} //
shell = hs.shellFor {
packages = p: [ p.symantic-parser ];
nativeBuildInputs = [
- hs.cabal-install
- hs.haskell-language-server
- hs.hpc
+ #hs.cabal-install
+ #hs.haskell-language-server
+ #hs.hpc
];
buildInputs = [
#hs.ghcid
#hs.ormolu
- hs.hlint
+ #hs.hlint
#pkgs.nixpkgs-fmt
];
inherit withHoogle;
},
"nixpkgs": {
"locked": {
- "narHash": "sha256-YguZIk8srZWuZm3zW2PI+ejtqjai8E/93p0PnW+mg64=",
- "path": "/nix/store/2zcg6zxdi5izyaamn0z5xff2px8799jh-nixpkgs-patched",
+ "narHash": "sha256-tu98g+a0ObP2yo1rJ9K3gRxok9Dgq7Vqpjqyykm+36Y=",
+ "path": "/nix/store/4wwgfpg9fg7wiivj6c556w7zsmsfpim5-nixpkgs-patched",
"type": "path"
},
"original": {
import Symantic.Parser.Automaton.Dump
import Symantic.Parser.Grammar
+import Symantic.Parser.Automaton.Input
import Data.Function ((.))
import qualified Language.Haskell.TH.Syntax as TH
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
+import Data.Kind (Type)
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Text.Show (Show(..))
import Symantic.Parser.Automaton.Instructions
-- * Type 'DumpInstr'
-newtype DumpInstr inp (vs:: [*]) (es::Peano) a x
+newtype DumpInstr inp (vs:: [Type]) (es::Peano) a x
= DumpInstr { unDumpInstr ::
Tree.Forest String -> Tree.Forest String }
{-# LANGUAGE ConstraintKinds #-} -- For Executable
{-# LANGUAGE PatternSynonyms #-} -- For Fmap, App, …
-{-# LANGUAGE DerivingStrategies #-} -- For Show (Addr a)
+{-# LANGUAGE DerivingStrategies #-} -- For Show (Label a)
module Symantic.Parser.Automaton.Instructions where
import Data.Bool (Bool)
import Data.Either (Either)
import Data.Eq (Eq)
import Data.Function (($), (.))
+import Data.Kind (Type)
import Text.Show (Show(..), showString)
import qualified Data.Functor as Functor
-import qualified Language.Haskell.TH.Syntax as TH
-import qualified Symantic.Parser.Staging as Hask
+import qualified Language.Haskell.TH as TH
+import qualified Symantic.Parser.Staging as H
import Symantic.Parser.Grammar
+import Symantic.Parser.Automaton.Input
import Symantic.Univariant.Trans
--- * Class 'InputPosition'
--- | TODO
-class InputPosition inp where
-instance InputPosition ()
-
-- * Type 'Instr'
-- | 'Instr'uctions for the 'Automaton'.
data Instr input valueStack (exceptionStack::Peano) returnValue a where
[Instr inp vs es ret a] ->
Instr inp vs es ret a ->
Instr inp (x ': vs) es ret a
- -- | @('Subroutine' n v k)@ binds the 'Addr' @(n)@ to the 'Instr'uction's @(v)@,
+ -- | @('Subroutine' n v k)@ binds the 'Label' @(n)@ to the 'Instr'uction's @(v)@,
-- continues with the next 'Instr'uction @(k)@.
Subroutine ::
- Addr x ->
+ Label x ->
Instr inp '[] ('Succ es) x a ->
Instr inp vs ('Succ es) ret a ->
Instr inp vs ('Succ es) ret a
-- | @('Jump' n k)@ pass the control-flow to the 'Subroutine' named @(n)@.
Jump ::
- Addr ret ->
+ Label ret ->
Instr inp '[] ('Succ es) ret a
-- | @('Call' n k)@ pass the control-flow to the 'Subroutine' named @(n)@,
-- and when it 'Ret'urns, continues with the next 'Instr'uction @(k)@.
Call ::
- Addr x ->
+ Label x ->
Instr inp (x ': vs) ('Succ es) ret a ->
Instr inp vs ('Succ es) ret a
-- | @('Ret')@ returns the value stored in a singleton value-stack.
Instr inp vs ('Succ es) ret a
-- ** Type 'InstrPure'
-data InstrPure a
- = InstrPureHaskell (Hask.Haskell a)
- | InstrPureSameOffset
+data InstrPure a where
+ InstrPureHaskell :: H.Haskell a -> InstrPure a
+ InstrPureSameOffset :: InputPosition inp => InstrPure (inp -> inp -> Bool)
+
instance Show (InstrPure a) where
showsPrec p = \case
InstrPureHaskell x -> showsPrec p x
InstrPureSameOffset -> showString "InstrPureSameOffset"
+instance Trans InstrPure TH.CodeQ where
+ trans = \case
+ InstrPureHaskell x -> trans x
+ InstrPureSameOffset -> same
--- ** Type 'Addr'
-newtype Addr a = Addr { unLabel :: TH.Name }
+-- ** Type 'Label'
+newtype Label a = Label { unLabel :: TH.Name }
deriving (Eq)
deriving newtype Show
)
-- ** Class 'Stackable'
-class Stackable (repr :: * -> [*] -> Peano -> * -> * -> *) where
+class Stackable (repr :: Type -> [Type] -> Peano -> Type -> Type -> Type) where
push ::
InstrPure x ->
repr inp (x ': vs) n ret a ->
repr inp (y ': x ': vs) n r a
-- ** Class 'Branchable'
-class Branchable (repr :: * -> [*] -> Peano -> * -> * -> *) where
+class Branchable (repr :: Type -> [Type] -> Peano -> Type -> Type -> Type) where
case_ ::
repr inp (x ': vs) n r a ->
repr inp (y ': vs) n r a ->
repr inp (x ': vs) es ret a
-- ** Class 'Exceptionable'
-class Exceptionable (repr :: * -> [*] -> Peano -> * -> * -> *) where
+class Exceptionable (repr :: Type -> [Type] -> Peano -> Type -> Type -> Type) where
fail :: repr inp vs ('Succ es) ret a
commit ::
repr inp vs es ret a ->
repr inp vs es ret a
-- ** Class 'Inputable'
-class Inputable (repr :: * -> [*] -> Peano -> * -> * -> *) where
+class Inputable (repr :: Type -> [Type] -> Peano -> Type -> Type -> Type) where
seek ::
repr inp vs es r a ->
repr inp (inp ': vs) es r a
repr inp vs es ret a
-- ** Class 'Routinable'
-class Routinable (repr :: * -> [*] -> Peano -> * -> * -> *) where
+class Routinable (repr :: Type -> [Type] -> Peano -> Type -> Type -> Type) where
subroutine ::
- Addr x ->
+ Label x ->
repr inp '[] ('Succ es) x a ->
repr inp vs ('Succ es) ret a ->
repr inp vs ('Succ es) ret a
call ::
- Addr x ->
+ Label x ->
repr inp (x ': vs) ('Succ es) ret a ->
repr inp vs ('Succ es) ret a
ret ::
repr inp '[ret] es ret a
jump ::
- Addr ret ->
+ Label ret ->
repr inp '[] ('Succ es) ret a
-- ** Class 'Readable'
-class Readable (repr :: * -> [*] -> Peano -> * -> * -> *) where
+class Readable (repr :: Type -> [Type] -> Peano -> Type -> Type -> Type) where
read ::
InstrPure (Char -> Bool) ->
repr inp (Char ': vs) ('Succ es) ret a ->
InstrPure (x -> y) ->
Instr inp (y ': xs) es ret a ->
Instr inp (x ': xs) es ret a
-pattern Fmap f k = Push f (LiftI2 (InstrPureHaskell (Hask.Flip Hask.:@ (Hask.:$))) k)
+pattern Fmap f k = Push f (LiftI2 (InstrPureHaskell (H.Flip H.:@ (H.:$))) k)
-- | @('App' k)@ pops @(x)@ and @(x2y)@ from the value-stack,
-- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.
pattern App :: Instr inp (y : vs) es ret a -> Instr inp (x : (x -> y) : vs) es ret a
-pattern App k = LiftI2 (InstrPureHaskell (Hask.:$)) k
+pattern App k = LiftI2 (InstrPureHaskell (H.:$)) k
-- | @('If' ok ko)@ pops a 'Bool' from the value-stack
-- and continues either with the 'Instr'uction @(ok)@ if it is 'True'
-- or @(ko)@ otherwise.
pattern If :: Instr inp vs es ret a -> Instr inp vs es ret a -> Instr inp (Bool ': vs) es ret a
-pattern If ok ko = Choices [InstrPureHaskell Hask.Id] [ok] ko
+pattern If ok ko = Choices [InstrPureHaskell H.Id] [ok] ko
parsecHandler :: InputPosition inp => Instr inp vs ('Succ es) ret a -> Instr inp (inp : vs) ('Succ es) ret a
parsecHandler k = Tell (LiftI2 InstrPureSameOffset (If k Fail))
forall inp a es repr.
Executable repr =>
Automaton inp a a -> (repr inp '[] ('Succ es) a) a
-runAutomaton =
- trans @(Instr inp '[] ('Succ es) a) .
- ($ Ret) .
- unAutomaton
+runAutomaton (Automaton auto) =
+ trans @(Instr inp '[] ('Succ es) a) $
+ auto Ret
instance Applicable (Automaton inp a) where
pure x = Automaton $ Push (InstrPureHaskell x)
Tell (x (Swap (Seek k)))
negLook (Automaton x) = Automaton $ \k ->
Catch (Tell (x (Pop (Seek (Commit Fail)))))
- (Seek (Push (InstrPureHaskell Hask.unit) k))
+ (Seek (Push (InstrPureHaskell H.unit) k))
instance Letable TH.Name (Automaton inp a) where
def n (Automaton v) = Automaton $ \k ->
- Subroutine (Addr n) (v Ret) (Call (Addr n) k)
+ Subroutine (Label n) (v Ret) (Call (Label n) k)
ref _isRec n = Automaton $ \case
- Ret -> Jump (Addr n)
- k -> Call (Addr n) k
+ Ret -> Jump (Label n)
+ k -> Call (Label n) k
instance InputPosition inp => Foldable (Automaton inp a) where
{-
chainPre op p = go <*> p
- where go = (Hask..) <$> op <*> go <|> pure Hask.id
+ where go = (H..) <$> op <*> go <|> pure H.id
chainPost p op = p <**> go
- where go = (Hask..) <$> op <*> go <|> pure Hask.id
+ where go = (H..) <$> op <*> go <|> pure H.id
-}
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.String (String)
-import Language.Haskell.TH (TExpQ)
+import Language.Haskell.TH (CodeQ)
import qualified Data.Functor as Functor
import qualified Data.List as List
import qualified Symantic.Univariant.Trans as Sym
-import qualified Symantic.Parser.Staging as Hask
+import qualified Symantic.Parser.Staging as H
-- * Class 'Applicable'
-- | This is like the usual 'Functor' and 'Applicative' type classes
--- from the @base@ package, but using @('Hask.Haskell' a)@ instead of just @(a)@
+-- from the @base@ package, but using @('H.Haskell' a)@ instead of just @(a)@
-- to be able to use and pattern match on some usual terms of type @(a)@ (like
--- 'Hask.id') and thus apply some optimizations.
+-- 'H.id') and thus apply some optimizations.
-- @(repr)@ , for "representation", is the usual tagless-final abstraction
-- over the many semantics that this syntax (formed by the methods
-- of type class like this one) will be interpreted.
class Applicable repr where
-- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
- (<$>) :: Hask.Haskell (a -> b) -> repr a -> repr b
+ (<$>) :: H.Haskell (a -> b) -> repr a -> repr b
(<$>) f = (pure f <*>)
-- | Like '<$>' but with its arguments 'flip'-ped.
- (<&>) :: repr a -> Hask.Haskell (a -> b) -> repr b
+ (<&>) :: repr a -> H.Haskell (a -> b) -> repr b
(<&>) = flip (<$>)
-- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
- (<$) :: Hask.Haskell a -> repr b -> repr a
+ (<$) :: H.Haskell a -> repr b -> repr a
(<$) x = (pure x <*)
-- | @(ra '$>' b)@ parses like @(ra)@ but discards its returned value by replacing it with @(b)@.
- ($>) :: repr a -> Hask.Haskell b -> repr b
+ ($>) :: repr a -> H.Haskell b -> repr b
($>) = flip (<$)
-- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
- pure :: Hask.Haskell a -> repr a
+ pure :: H.Haskell a -> repr a
default pure ::
Sym.Liftable repr => Applicable (Sym.Output repr) =>
- Hask.Haskell a -> repr a
+ H.Haskell a -> repr a
pure = Sym.lift . pure
-- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
-- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,
-- and returns the application of @(a2b2c)@ to the values returned by those parsers.
- liftA2 :: Hask.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
+ liftA2 :: H.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
liftA2 f x = (<*>) (f <$> x)
-- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@,
-- and returns like @(ra)@, discarding the return value of @(rb)@.
(<*) :: repr a -> repr b -> repr a
- (<*) = liftA2 Hask.const
+ (<*) = liftA2 H.const
-- | @(ra '*>' rb)@ parses sequentially @(ra)@ and then @(rb)@,
-- and returns like @(rb)@, discarding the return value of @(ra)@.
(*>) :: repr a -> repr b -> repr b
- x *> y = (Hask.id <$ x) <*> y
+ x *> y = (H.id <$ x) <*> y
-- | Like '<*>' but with its arguments 'flip'-ped.
(<**>) :: repr a -> repr (a -> b) -> repr b
- (<**>) = liftA2 (Hask.flip Hask..@ (Hask.$))
+ (<**>) = liftA2 (H.flip H..@ (H.$))
{-
(<**>) :: repr a -> repr (a -> b) -> repr b
(<**>) = liftA2 (\a f -> f a)
-- | Like @('<|>')@ but with different returning types for the alternatives,
-- and a return value wrapped in an 'Either' accordingly.
(<+>) :: Applicable repr => Alternable repr => repr a -> repr b -> repr (Either a b)
- p <+> q = Hask.left <$> p <|> Hask.right <$> q
+ p <+> q = H.left <$> p <|> H.right <$> q
infixl 3 <|>, <+>
-optionally :: Applicable repr => Alternable repr => repr a -> Hask.Haskell b -> repr b
+optionally :: Applicable repr => Alternable repr => repr a -> H.Haskell b -> repr b
optionally p x = p $> x <|> pure x
optional :: Applicable repr => Alternable repr => repr a -> repr ()
-optional = flip optionally Hask.unit
+optional = flip optionally H.unit
-option :: Applicable repr => Alternable repr => Hask.Haskell a -> repr a -> repr a
+option :: Applicable repr => Alternable repr => H.Haskell a -> repr a -> repr a
option x p = p <|> pure x
choice :: Alternable repr => [repr a] -> repr a
-- but at this point there is no asum for our own (<|>)
maybeP :: Applicable repr => Alternable repr => repr a -> repr (Maybe a)
-maybeP p = option Hask.nothing (Hask.just <$> p)
+maybeP p = option H.nothing (H.just <$> p)
manyTill :: Applicable repr => Alternable repr => repr a -> repr b -> repr [a]
-manyTill p end = let go = end $> Hask.nil <|> p <:> go in go
+manyTill p end = let go = end $> H.nil <|> p <:> go in go
-- * Class 'Selectable'
class Selectable repr where
-- * Class 'Matchable'
class Matchable repr where
conditional ::
- Eq a => [Hask.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
+ Eq a => [H.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
default conditional ::
Sym.Unliftable repr => Sym.Liftable2 repr => Matchable (Sym.Output repr) =>
- Eq a => [Hask.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
+ Eq a => [H.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
conditional cs bs = Sym.lift2 (conditional cs (Sym.trans Functor.<$> bs))
- match :: Eq a => [Hask.Haskell a] -> repr a -> (Hask.Haskell a -> repr b) -> repr b -> repr b
- match as a a2b = conditional (Hask.eq Functor.<$> as) (a2b Functor.<$> as) a
+ match :: Eq a => [H.Haskell a] -> repr a -> (H.Haskell a -> repr b) -> repr b -> repr b
+ match as a a2b = conditional (H.eq Functor.<$> as) (a2b Functor.<$> as) a
-- * Class 'Foldable'
class Foldable repr where
Alternable repr =>
repr a -> repr (a -> a) -> repr a
chainPre op p = go <*> p
- where go = (Hask..) <$> op <*> go <|> pure Hask.id
+ where go = (H..) <$> op <*> go <|> pure H.id
chainPost p op = p <**> go
- where go = (Hask..) <$> op <*> go <|> pure Hask.id
+ where go = (H..) <$> op <*> go <|> pure H.id
{-
-conditional :: Selectable repr => [(Hask.Haskell (a -> Bool), repr b)] -> repr a -> repr b -> repr b
+conditional :: Selectable repr => [(H.Haskell (a -> Bool), repr b)] -> repr a -> repr b -> repr b
conditional cs p def = match p fs qs def
where (fs, qs) = List.unzip cs
-}
-- * Class 'Charable'
class Charable repr where
- satisfy :: Hask.Haskell (Char -> Bool) -> repr Char
+ satisfy :: H.Haskell (Char -> Bool) -> repr Char
default satisfy ::
Sym.Liftable repr => Charable (Sym.Output repr) =>
- Hask.Haskell (Char -> Bool) -> repr Char
+ H.Haskell (Char -> Bool) -> repr Char
satisfy = Sym.lift . satisfy
-- * Class 'Lookable'
{-# INLINE (<:>) #-}
infixl 4 <:>
(<:>) :: Applicable repr => repr a -> repr [a] -> repr [a]
-(<:>) = liftA2 Hask.cons
+(<:>) = liftA2 H.cons
sequence :: Applicable repr => [repr a] -> repr [a]
-sequence = List.foldr (<:>) (pure Hask.nil)
+sequence = List.foldr (<:>) (pure H.nil)
traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
traverse f = sequence . List.map f
-- oneOf cs = satisfy (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])
noneOf :: Charable repr => String -> repr Char
-noneOf cs = satisfy (Hask.Haskell Hask.ValueCode{..})
+noneOf cs = satisfy (H.Haskell H.ValueCode{..})
where
- value = Hask.Value (not . flip List.elem cs)
- code = Hask.Code [||\c -> not $$(ofChars cs [||c||])||]
+ value = H.Value (not . flip List.elem cs)
+ code = [||\c -> not $$(ofChars cs [||c||])||]
-ofChars :: String -> TExpQ Char -> TExpQ Bool
+ofChars :: String -> CodeQ Char -> CodeQ Bool
ofChars = List.foldr (\c rest qc -> [|| c == $$qc || $$(rest qc) ||]) (const [||False||])
token :: Applicable repr => Alternable repr => Charable repr => String -> repr String
more = look (void item)
char :: Applicable repr => Charable repr => Char -> repr Char
-char c = satisfy (Hask.eq (Hask.char c)) $> Hask.char c
+char c = satisfy (H.eq (H.char c)) $> H.char c
item :: Charable repr => repr Char
-item = satisfy (Hask.const Hask..@ Hask.bool True)
+item = satisfy (H.const H..@ H.bool True)
-- Composite Combinators
-- someTill :: repr a -> repr b -> repr [a]
void p = p *> unit
unit :: Applicable repr => repr ()
-unit = pure Hask.unit
+unit = pure H.unit
{-
constp :: Applicable repr => repr a -> repr (b -> a)
-constp = (Hask.const <$>)
+constp = (H.const <$>)
-- Alias Operations
infixl 4 <~>
(<~>) :: Applicable repr => repr a -> repr b -> repr (a, b)
-(<~>) = liftA2 (Hask.runtime (,))
+(<~>) = liftA2 (H.runtime (,))
infixl 4 <~
(<~) :: Applicable repr => repr a -> repr b -> repr a
-- Lift Operations
liftA2 ::
Applicable repr =>
- Hask.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
+ H.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
liftA2 f x = (<*>) (fmap f x)
liftA3 ::
Applicable repr =>
- Hask.Haskell (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
+ H.Haskell (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
liftA3 f a b c = liftA2 f a b <*> c
-}
-- Parser Folds
pfoldr ::
Applicable repr => Foldable repr =>
- Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
+ H.Haskell (a -> b -> b) -> H.Haskell b -> repr a -> repr b
pfoldr f k p = chainPre (f <$> p) (pure k)
pfoldr1 ::
Applicable repr => Foldable repr =>
- Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
+ H.Haskell (a -> b -> b) -> H.Haskell b -> repr a -> repr b
pfoldr1 f k p = f <$> p <*> pfoldr f k p
pfoldl ::
Applicable repr => Foldable repr =>
- Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
-pfoldl f k p = chainPost (pure k) ((Hask.flip <$> pure f) <*> p)
+ H.Haskell (b -> a -> b) -> H.Haskell b -> repr a -> repr b
+pfoldl f k p = chainPost (pure k) ((H.flip <$> pure f) <*> p)
pfoldl1 ::
Applicable repr => Foldable repr =>
- Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
-pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Hask.flip <$> pure f) <*> p)
+ H.Haskell (b -> a -> b) -> H.Haskell b -> repr a -> repr b
+pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((H.flip <$> pure f) <*> p)
-- Chain Combinators
chainl1' ::
Applicable repr => Foldable repr =>
- Hask.Haskell (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
-chainl1' f p op = chainPost (f <$> p) (Hask.flip <$> op <*> p)
+ H.Haskell (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
+chainl1' f p op = chainPost (f <$> p) (H.flip <$> op <*> p)
chainl1 ::
Applicable repr => Foldable repr =>
repr a -> repr (a -> a -> a) -> repr a
-chainl1 = chainl1' Hask.id
+chainl1 = chainl1' H.id
{-
chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
-chainr1' f p op = newRegister_ Hask.id $ \acc ->
+chainr1' f p op = newRegister_ H.id $ \acc ->
let go = bind p $ \x ->
- modify acc (Hask.flip (Hask..@) <$> (op <*> x)) *> go
+ modify acc (H.flip (H..@) <$> (op <*> x)) *> go
<|> f <$> x
in go <**> get acc
chainr1 :: repr a -> repr (a -> a -> a) -> repr a
-chainr1 = chainr1' Hask.id
+chainr1 = chainr1' H.id
-chainr :: repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
+chainr :: repr a -> repr (a -> a -> a) -> H.Haskell a -> repr a
chainr p op x = option x (chainr1 p op)
-}
chainl ::
Applicable repr => Alternable repr => Foldable repr =>
- repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
+ repr a -> repr (a -> a -> a) -> H.Haskell a -> repr a
chainl p op x = option x (chainl1 p op)
-- Derived Combinators
many ::
Applicable repr => Foldable repr =>
repr a -> repr [a]
-many = pfoldr Hask.cons Hask.nil
+many = pfoldr H.cons H.nil
manyN ::
Applicable repr => Foldable repr =>
Applicable repr => Foldable repr =>
repr a -> repr ()
--skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
-skipMany = void . pfoldl Hask.const Hask.unit -- the void here will encourage the optimiser to recognise that the register is unused
+skipMany = void . pfoldl H.const H.unit -- the void here will encourage the optimiser to recognise that the register is unused
skipManyN ::
Applicable repr => Foldable repr =>
sepBy ::
Applicable repr => Alternable repr => Foldable repr =>
repr a -> repr b -> repr [a]
-sepBy p sep = option Hask.nil (sepBy1 p sep)
+sepBy p sep = option H.nil (sepBy1 p sep)
sepBy1 ::
Applicable repr => Alternable repr => Foldable repr =>
sepEndBy ::
Applicable repr => Alternable repr => Foldable repr =>
repr a -> repr b -> repr [a]
-sepEndBy p sep = option Hask.nil (sepEndBy1 p sep)
+sepEndBy p sep = option H.nil (sepEndBy1 p sep)
sepEndBy1 ::
Applicable repr => Alternable repr => Foldable repr =>
repr a -> repr b -> repr [a]
sepEndBy1 p sep =
- let seb1 = p <**> (sep *> (Hask.flip Hask..@ Hask.cons <$> option Hask.nil seb1)
- <|> pure (Hask.flip Hask..@ Hask.cons Hask..@ Hask.nil))
+ let seb1 = p <**> (sep *> (H.flip H..@ H.cons <$> option H.nil seb1)
+ <|> pure (H.flip H..@ H.cons H..@ H.nil))
in seb1
{-
sepEndBy1 :: repr a -> repr b -> repr [a]
-sepEndBy1 p sep = newRegister_ Hask.id $ \acc ->
- let go = modify acc ((Hask.flip (Hask..)) Hask..@ Hask.cons <$> p)
+sepEndBy1 p sep = newRegister_ H.id $ \acc ->
+ let go = modify acc ((H.flip (H..)) H..@ H.cons <$> p)
*> (sep *> (go <|> get acc) <|> get acc)
- in go <*> pure Hask.nil
+ in go <*> pure H.nil
-}
{-
import qualified Symantic.Parser.Grammar.Combinators as Comb
import qualified Language.Haskell.TH.Syntax as TH
--- | Like 'Letable.observeSharing' but type-binding @(letName)@ to 'TH.Name' to help type inference.
+-- | Like 'Letable.observeSharing'
+-- but type-binding @(letName)@ to 'TH.Name' to help type inference.
observeSharing :: ObserveSharing TH.Name repr a -> repr a
observeSharing = Letable.observeSharing
, Hashable letName
, Comb.Matchable repr
) => Comb.Matchable (ObserveSharing letName repr) where
- -- Here the default definition does not fit since there is no lift* for its type and thus handles 'bs' itself,
- -- which is not the transformation wanted.
+ -- Here the default definition does not fit
+ -- since there is no lift* for the type of 'conditional'
+ -- and its default definition handles does not handles 'bs'
+ -- as needed by the 'ObserveSharing' transformation.
conditional cs bs a b = observeSharingNode $ ObserveSharing $
Comb.conditional cs
<$> mapM unObserveSharing bs
import Data.Eq (Eq(..))
import Data.Foldable (all, foldr)
import Data.Function ((.))
+import Data.Kind (Type)
import qualified Data.Functor as Functor
import qualified Data.List as List
import qualified Language.Haskell.TH.Syntax as TH
import Symantic.Parser.Grammar.Combinators as Comb
-import Symantic.Parser.Staging (ValueCode(..), Value(..), Code(..), getValue, getCode)
+import Symantic.Parser.Staging (ValueCode(..), Value(..), getValue, code)
import Symantic.Univariant.Letable
import Symantic.Univariant.Trans
-import qualified Symantic.Parser.Staging as Hask
+import qualified Symantic.Parser.Staging as H
-- import Debug.Trace (trace)
-- 2. Avoid overlapping instances between
-- @('Trans' ('Comb' repr) repr)@ and
-- @('Trans' ('Comb' repr) ('OptimizeComb' letName repr))@
-data Comb (repr :: * -> *) a where
- Pure :: Hask.Haskell a -> Comb repr a
- Satisfy :: Hask.Haskell (Char -> Bool) -> Comb repr Char
+data Comb (repr :: Type -> Type) a where
+ Pure :: H.Haskell a -> Comb repr a
+ Satisfy :: H.Haskell (Char -> Bool) -> Comb repr Char
Item :: Comb repr Char
Try :: Comb repr a -> Comb repr a
Look :: Comb repr a -> Comb repr a
(:<|>) :: Comb repr a -> Comb repr a -> Comb repr a
Empty :: Comb repr a
Branch :: Comb repr (Either a b) -> Comb repr (a -> c) -> Comb repr (b -> c) -> Comb repr c
- Match :: Eq a => [Hask.Haskell (a -> Bool)] -> [Comb repr b] -> Comb repr a -> Comb repr b -> Comb repr b
+ Match :: Eq a => [H.Haskell (a -> Bool)] -> [Comb repr b] -> Comb repr a -> Comb repr b -> Comb repr b
ChainPre :: Comb repr (a -> a) -> Comb repr a -> Comb repr a
ChainPost :: Comb repr a -> Comb repr (a -> a) -> Comb repr a
Def :: TH.Name -> Comb repr a -> Comb repr a
Ref :: Bool -> TH.Name -> Comb repr a
-pattern (:<$>) :: Hask.Haskell (a -> b) -> Comb repr a -> Comb repr b
-pattern (:$>) :: Comb repr a -> Hask.Haskell b -> Comb repr b
-pattern (:<$) :: Hask.Haskell a -> Comb repr b -> Comb repr a
+pattern (:<$>) :: H.Haskell (a -> b) -> Comb repr a -> Comb repr b
+pattern (:$>) :: Comb repr a -> H.Haskell b -> Comb repr b
+pattern (:<$) :: H.Haskell a -> Comb repr b -> Comb repr a
pattern (:*>) :: Comb repr a -> Comb repr b -> Comb repr b
pattern (:<*) :: Comb repr a -> Comb repr b -> Comb repr a
pattern x :<$> p = Pure x :<*> p
pattern p :$> x = p :*> Pure x
pattern x :<$ p = Pure x :<* p
-pattern x :<* p = Hask.Const :<$> x :<*> p
-pattern p :*> x = Hask.Id :<$ p :<*> x
+pattern x :<* p = H.Const :<$> x :<*> p
+pattern p :*> x = H.Id :<$ p :<*> x
infixl 3 :<|>
infixl 4 :<*>, :<*, :*>
optimizeCombNode :: Comb repr a -> Comb repr a
optimizeCombNode = \case
-- Functor Identity Law
- Hask.Id :<$> x ->
+ H.Id :<$> x ->
-- trace "Functor Identity Law" $
x
-- Functor Commutativity Law
-- trace "Functor Commutativity Law" $
optimizeCombNode (u :$> x)
-- Functor Flip Const Law
- Hask.Flip Hask.:@ Hask.Const :<$> u ->
+ H.Flip H.:@ H.Const :<$> u ->
-- trace "Functor Flip Const Law" $
- optimizeCombNode (u :*> Pure Hask.Id)
+ optimizeCombNode (u :*> Pure H.Id)
-- Functor Homomorphism Law
f :<$> Pure x ->
-- trace "Functor Homomorphism Law" $
- Pure (f Hask..@ x)
+ Pure (f H..@ x)
-- App Right Absorption Law
Empty :<*> _ ->
-- App Composition Law
u :<*> (v :<*> w) ->
-- trace "App Composition Law" $
- optimizeCombNode (optimizeCombNode (optimizeCombNode ((Hask.:.) :<$> u) :<*> v) :<*> w)
+ optimizeCombNode (optimizeCombNode (optimizeCombNode ((H.:.) :<$> u) :<*> v) :<*> w)
-- App Interchange Law
u :<*> Pure x ->
-- trace "App Interchange Law" $
- optimizeCombNode (Hask.Flip Hask..@ (Hask.:$) Hask..@ x :<$> u)
+ optimizeCombNode (H.Flip H..@ (H.:$) H..@ x :<$> u)
-- App Left Absorption Law
p :<* (_ :<$> q) ->
-- trace "App Left Absorption Law" $
-- NegLook Empty Law
NegLook Empty ->
-- trace "NegLook Dead Law" $
- Pure Hask.unit
+ Pure H.unit
-- NegLook Double Negation Law
NegLook (NegLook p) ->
-- trace "NegLook Double Negation Law" $
- optimizeCombNode (Look (Try p) :*> Pure Hask.unit)
+ optimizeCombNode (Look (Try p) :*> Pure H.unit)
-- NegLook Zero Consumption Law
NegLook (Try p) ->
-- trace "NegLook Zero Consumption Law" $
-- NegLook Absorption Law
p :<*> NegLook q ->
-- trace "Neglook Absorption Law" $
- optimizeCombNode (optimizeCombNode (p :<*> Pure Hask.unit) :<* NegLook q)
+ optimizeCombNode (optimizeCombNode (p :<*> Pure H.unit) :<* NegLook q)
-- NegLook Idempotence Right Law
NegLook (_ :<$> p) ->
-- trace "NegLook Idempotence Law" $
Branch (Pure (trans -> lr)) l r ->
-- trace "Branch Pure Left/Right Law" $
case getValue lr of
- Left v -> optimizeCombNode (l :<*> Pure (Hask.Haskell (ValueCode (Value v) c)))
- where c = Code [|| case $$(getCode lr) of Left x -> x ||]
- Right v -> optimizeCombNode (r :<*> Pure (Hask.Haskell (ValueCode (Value v) c)))
- where c = Code [|| case $$(getCode lr) of Right x -> x ||]
+ Left v -> optimizeCombNode (l :<*> Pure (H.Haskell (ValueCode (Value v) c)))
+ where c = [|| case $$(code lr) of Left x -> x ||]
+ Right v -> optimizeCombNode (r :<*> Pure (H.Haskell (ValueCode (Value v) c)))
+ where c = [|| case $$(code lr) of Right x -> x ||]
-- Branch Generalised Identity Law
Branch b (Pure (trans -> l)) (Pure (trans -> r)) ->
-- trace "Branch Generalised Identity Law" $
- optimizeCombNode (Hask.Haskell (ValueCode v c) :<$> b)
+ optimizeCombNode (H.Haskell (ValueCode v c) :<$> b)
where
v = Value (either (getValue l) (getValue r))
- c = Code [|| either $$(getCode l) $$(getCode r) ||]
+ c = [|| either $$(code l) $$(code r) ||]
-- Branch Interchange Law
Branch (x :*> y) p q ->
-- trace "Branch Interchange Law" $
-- Branch Empty Right Law
Branch b l Empty ->
-- trace " Branch Empty Right Law" $
- Branch (Pure (Hask.Haskell (ValueCode v c)) :<*> b) Empty l
+ Branch (Pure (H.Haskell (ValueCode v c)) :<*> b) Empty l
where
v = Value (either Right Left)
- c = Code [||either Right Left||]
+ c = [||either Right Left||]
-- Branch Fusion Law
Branch (Branch b Empty (Pure (trans -> lr))) Empty br ->
-- trace "Branch Fusion Law" $
- optimizeCombNode (Branch (optimizeCombNode (Pure (Hask.Haskell (ValueCode (Value v) c)) :<*> b))
+ optimizeCombNode (Branch (optimizeCombNode (Pure (H.Haskell (ValueCode (Value v) c)) :<*> b))
Empty br)
where
v Left{} = Left ()
v (Right r) = case getValue lr r of
Left _ -> Left ()
Right rr -> Right rr
- c = Code [|| \case Left{} -> Left ()
- Right r -> case $$(getCode lr) r of
- Left _ -> Left ()
- Right rr -> Right rr ||]
+ c = [|| \case Left{} -> Left ()
+ Right r -> case $$(code lr) r of
+ Left _ -> Left ()
+ Right rr -> Right rr ||]
-- Branch Distributivity Law
f :<$> Branch b l r ->
-- trace "Branch Distributivity Law" $
- optimizeCombNode (Branch b (optimizeCombNode ((Hask..@) (Hask..) f :<$> l))
- (optimizeCombNode ((Hask..@) (Hask..) f :<$> r)))
+ optimizeCombNode (Branch b (optimizeCombNode ((H..@) (H..) f :<$> l))
+ (optimizeCombNode ((H..@) (H..) f :<$> r)))
-- Match Absorption Law
Match _ _ Empty d ->
Empty :*> _ -> Empty
Empty :<* _ -> Empty
-- App Definition of *> Law
- Hask.Flip Hask..@ Hask.Const :<$> p :<*> q ->
+ H.Flip H..@ H.Const :<$> p :<*> q ->
-- trace "EXTRALAW: App Definition of *> Law" $
p :*> q
-- App Definition of <* Law
- Hask.Const :<$> p :<*> q ->
+ H.Const :<$> p :<*> q ->
-- trace "EXTRALAW: App Definition of <* Law" $
p :<* q
-- by the Composition Law and Homomorphism Law)
f :<$> (g :<$> p) ->
-- trace "EXTRALAW: Functor Composition Law" $
- optimizeCombNode ((Hask.:.) Hask..@ f Hask..@ g :<$> p)
+ optimizeCombNode ((H.:.) H..@ f H..@ g :<$> p)
-- Applicable Failure Weakening Law
u :<* Empty ->
-- trace "EXTRALAW: App Failure Weakening Law" $
-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
module Symantic.Parser.Staging where
-import Data.Bool (Bool)
+import Data.Bool (Bool(..))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
-import Language.Haskell.TH (TExpQ)
+import Data.Kind (Type)
import Text.Show (Show(..), showParen, showString)
import qualified Data.Eq as Eq
import qualified Data.Function as Fun
import qualified Data.Function as Function
+import qualified Language.Haskell.TH as TH
import Symantic.Univariant.Trans
-- * Type 'ValueCode'
--- | Compile-time 'value' and corresponding 'code' (that can produce that value at runtime).
+-- | Compile-time 'value' and corresponding 'code'
+-- (that can produce that value at runtime).
data ValueCode a = ValueCode
- { value :: Value a
- , code :: Code a
- }
+ { value :: Value a
+ , code :: TH.CodeQ a
+ }
getValue :: ValueCode a -> a
getValue = unValue Function.. value
-getCode :: ValueCode a -> TExpQ a
-getCode = unCode Function.. code
+getCode :: ValueCode a -> TH.CodeQ a
+getCode = code
-- ** Type 'Value'
newtype Value a = Value { unValue :: a }
--- ** Type 'Code'
-newtype Code a = Code { unCode :: TExpQ a }
-
-- * Class 'Haskellable'
-- | Final encoding of some Haskell functions
-- useful for some optimizations in 'optimizeComb'.
-class Haskellable (repr :: * -> *) where
+class Haskellable (repr :: Type -> Type) where
(.) :: repr ((b->c) -> (a->b) -> a -> c)
($) :: repr ((a->b) -> a -> b)
(.@) :: repr (a->b) -> repr a -> repr b
(:.) :: Haskell ((b->c) -> (a->b) -> a -> c)
(:$) :: Haskell ((a->b) -> a -> b)
(:@) :: Haskell (a->b) -> Haskell a -> Haskell b
+ Cons :: Haskell (a -> [a] -> [a])
Const :: Haskell (a -> b -> a)
+ Eq :: Eq a => Haskell a -> Haskell (a -> Bool)
Flip :: Haskell ((a -> b -> c) -> b -> a -> c)
Id :: Haskell (a->a)
Unit :: Haskell ()
infixr 0 $, :$
infixr 9 ., :.
infixl 9 .@, :@
+
+{-
+pattern (:.@) ::
+ -- Dummy constraint to get the following constraint
+ -- in scope when pattern-matching.
+ () =>
+ ((x -> y -> z) ~ ((b -> c) -> (a -> b) -> a -> c)) =>
+ Haskell x -> Haskell y -> Haskell z
+pattern (:.@) f g = (:.) :@ f :@ g
+pattern FlipApp ::
+ () =>
+ ((x -> y) ~ ((a -> b -> c) -> b -> a -> c)) =>
+ Haskell x -> Haskell y
+pattern FlipApp f = Flip :@ f
+pattern FlipConst ::
+ () =>
+ (x ~ (a -> b -> b)) =>
+ Haskell x
+pattern FlipConst = FlipApp Const
+-}
+
instance Show (Haskell a) where
showsPrec p = \case
Haskell{} -> showString "Haskell"
- (:.) -> showString "(.)"
(:$) -> showString "($)"
- (:@) ((:.) :@ f) g ->
+ (:.) :@ f :@ g ->
showParen (p >= 9)
Fun.$ showsPrec 9 f
Fun.. showString " . "
Fun.. showsPrec 9 g
- (:@) f x ->
+ (:.) -> showString "(.)"
+ Cons :@ x :@ xs ->
showParen (p >= 10)
- Fun.$ showsPrec 10 f
- Fun.. showString " "
- Fun.. showsPrec 10 x
+ Fun.$ showsPrec 10 x
+ Fun.. showString " : "
+ Fun.. showsPrec 10 xs
+ Cons -> showString "cons"
Const -> showString "const"
+ Eq x ->
+ showParen True
+ Fun.$ showString "== "
+ Fun.. showsPrec 0 x
Flip -> showString "flip"
Id -> showString "id"
Unit -> showString "()"
+ (:@) f x ->
+ showParen (p >= 10)
+ Fun.$ showsPrec 10 f
+ Fun.. showString " "
+ Fun.. showsPrec 10 x
+instance Trans Haskell Value where
+ trans = value Fun.. trans
+instance Trans Haskell TH.CodeQ where
+ trans = code Fun.. trans
instance Trans Haskell ValueCode where
trans = \case
Haskell x -> x
(:.) -> (.)
(:$) -> ($)
(:@) f x -> (.@) (trans f) (trans x)
+ Cons -> cons
Const -> const
+ Eq x -> eq (trans x)
Flip -> flip
Id -> id
Unit -> unit
Id .@ x = x
(Const :@ x) .@ _y = x
((Flip :@ Const) :@ _x) .@ y = y
+ --
f .@ x = f :@ x
+ cons = Cons
const = Const
+ eq = Eq
flip = Flip
id = Id
unit = Unit
bool b = Haskell (bool b)
char c = Haskell (char c)
- eq x = Haskell (eq (trans x))
- cons = Haskell cons
nil = Haskell nil
left = Haskell left
right = Haskell right
right = Value Right
nothing = Value Nothing
just = Value Just
-instance Haskellable Code where
- (.) = Code [|| \f g x -> f (g x) ||]
- ($) = Code [|| \f x -> f x ||]
- (.@) f x = Code [|| $$(unCode f) $$(unCode x) ||]
- bool b = Code [|| b ||]
- char c = Code [|| c ||]
- cons = Code [|| \x xs -> x : xs ||]
- const = Code [|| \x _ -> x ||]
- eq x = Code [|| \y -> $$(unCode x) Eq.== y ||]
- flip = Code [|| \f x y -> f y x ||]
- id = Code [|| \x -> x ||]
- nil = Code [|| [] ||]
- unit = Code [|| () ||]
- left = Code [|| Left ||]
- right = Code [|| Right ||]
- nothing = Code [|| Nothing ||]
- just = Code [|| Just ||]
+instance Haskellable TH.CodeQ where
+ (.) = [|| \f g x -> f (g x) ||]
+ ($) = [|| \f x -> f x ||]
+ (.@) f x = [|| $$f $$x ||]
+ bool b = [|| b ||]
+ char c = [|| c ||]
+ cons = [|| \x xs -> x : xs ||]
+ const = [|| \x _ -> x ||]
+ eq x = [|| \y -> $$x Eq.== y ||]
+ flip = [|| \f x y -> f y x ||]
+ id = [|| \x -> x ||]
+ nil = [|| [] ||]
+ unit = [|| () ||]
+ left = [|| Left ||]
+ right = [|| Right ||]
+ nothing = [|| Nothing ||]
+ just = [|| Just ||]
, oss_recs = HS.empty
}
let refs = HS.fromList $
- foldMap (\(letName, refCount) -> if refCount > 0 then [letName] else []) $
- HM.elems $ oss_refs st
+ (`foldMap` oss_refs st) $ (\(letName, refCount) ->
+ if refCount > 0 then [letName] else [])
-- trace (show refs) $
unCleanDefs a refs
-- TODO: move to symantic-univariant
import Data.Function ((.))
+import Data.Kind (Type)
-- * Type family 'Output'
-type family Output (repr :: * -> *) :: * -> *
+type family Output (repr :: Type -> Type) :: Type -> Type
-- * Class 'Trans'
-- | A 'trans'lation from an interpreter @(from)@ to an interpreter @(to)@.
-name: symantic-parser
+Name: symantic-parser
version: 0.0.0.0
synopsis: A Staging Parser
-description:
- This is an alternative but incomplete implementation of [ParsleyHaskell](https://github.com/J-mie6/ParsleyHaskell),
- using the tagless-final paradigm to handle combinators and recursion schemes.
+description:
+ This is an alternative but incomplete implementation of [ParsleyHaskell](https://github.com/J-mie6/ParsleyHaskell).
.
- At some point it should also support parsing tree-like data structures
- (like XML or HTTP routes) instead of just string-like data structures.
+ Main improvements are:
+ .
+ * Tagless-final and DefaultSignaturesa are used
+ instead of tagfull-final to handle recursion schemes,
+ this avoids constructing and deconstructing tags when transforming
+ combinators or instructions.
+ And structures/simplifies the code by avoiding to define
+ custom traversals (traverseCombinator)
+ or custom fix-point data-types (Fix4)
+ and associated utilities (cata4) when introducing new index-types.
+ Note that the extensibility of combinators, a great feature of tagless-final,
+ is not really achievable when using the optimizing pass
+ which requires a comprehensive initial encoding.
+ * No dependency on dependant-map by keeping observed sharing
+ inside 'def' and 'ref' combinators, instead of passing by a DependantMap.
+ * No dependency on GHC plugins: lift-plugin and idioms-plugin,
+ because those are plugins hence introduce a bit of complexity
+ in the build process, but most importantly they are experimental
+ and only cosmetic, since they only enable a cleaner usage
+ of the parsing combinators, by lifting Haskell code in 'pure'
+ to integrate the TemplateHaskell needed.
+ I do not understand them (yet) and do not feel confortable
+ to maintain them in case their authors abandon them.
+ .
+ Goals are:
+ .
+ * For me to understand ParsleyHaskell, and find a manageable balance
+ between simplicity of the codebase and features of the parser.
+ * To support parsing tree-like data structures (like XML or HTTP routes)
+ instead of just string-like data structures,
+ which is doable with megaparsec, but is hard and less principled
+ when it comes to optimize, like merging alternatives.
+ * To have unit tests.
+ .
+ TODO:
+ .
+ * Eval instructions
+ * Collect subroutines in a big recursive LetE
+ * Inputable instances
+ * Join points
+ * Errors
+ * Registers
license: GPL-3
-- license-file: LICENSE
author: Julien Moutinho <julm+symantic-parser@sourcephile.fr>
Symantic.Univariant.Letable
Symantic.Parser
Symantic.Parser.Automaton
- Symantic.Parser.Automaton.Instructions
Symantic.Parser.Automaton.Dump
+ Symantic.Parser.Automaton.Instructions
Symantic.Parser.Grammar
Symantic.Parser.Grammar.Combinators
Symantic.Parser.Grammar.Dump
GeneralizedNewtypeDeriving,
LambdaCase,
MultiParamTypeClasses,
+ NamedFieldPuns,
NoImplicitPrelude,
RankNTypes,
RecordWildCards,
-- QuickCheck >= 2.0,
-- tasty-quickcheck,
unordered-containers
+
+-- Executable symantic-parser
+-- hs-source-dirs: exe
+-- main-is: Main.hs
+-- other-modules:
+-- default-language: Haskell2010
+-- default-extensions:
+-- LambdaCase
+-- NamedFieldPuns
+-- NoImplicitPrelude
+-- RecordWildCards
+-- TypeFamilies
+-- ViewPatterns
+-- ghc-options:
+-- -Wall
+-- -Wincomplete-uni-patterns
+-- -Wincomplete-record-updates
+-- -fhide-source-paths
+-- -threaded -rtsopts
+-- -freverse-errors
+-- build-depends:
+-- symantic-parser,
+-- base >= 4.10 && < 5,
+-- bytestring >= 0.10,
+-- containers >= 0.5,
+-- deepseq >= 1.4,
+-- hashable >= 1.2.6,
+-- text >= 1.2,
+-- transformers >= 0.4,
+-- unordered-containers,
+-- unix
import qualified Language.Haskell.TH.Syntax as TH
import qualified Symantic.Parser as P
-import qualified Symantic.Parser.Staging as Hask
+import qualified Symantic.Parser.Staging as H
import qualified Golden.Grammar as Grammar
goldensIO :: IO TestTree
tests test =
[ test "unit" $ P.unit
, test "unit-unit" $ P.unit P.*> P.unit
- , test "app" $ P.pure (Hask.Haskell Hask.id) P.<*> P.unit
+ , test "app" $ P.pure (H.Haskell H.id) P.<*> P.unit
+ , test "many-a" $ P.many (P.char 'a')
, test "boom" $ Grammar.boom
, test "brainfuck" $ Grammar.brainfuck
]
[ test "unit" $ P.automaton $ P.unit
, test "unit-unit" $ P.automaton $ P.unit P.*> P.unit
, test "a-or-b" $ P.automaton $ P.char 'a' P.<|> P.char 'b'
- , test "app" $ P.automaton $ P.pure (Hask.Haskell Hask.id) P.<*> P.unit
+ , test "app" $ P.automaton $ P.pure (H.Haskell H.id) P.<*> P.unit
+ , test "many-a" $ P.automaton $ P.many (P.char 'a')
, test "boom" $ P.automaton $ Grammar.boom
, test "brainfuck" $ P.automaton $ Grammar.brainfuck
]
-push ((.) ((flip ($)) (const id)) . ((.) (.) . ((.) (.) . ((.) (const id) . const id))))
-let_3:
+push ((.) ((.) (.)) . ((.) ((.) (.)) . (.) ((.) (const id))))
+let_1:
| push (const id)
+| ret
+call let_1
+lift ($)
+let_3:
+| let_4:
+| | push (const id)
+| | ret
+| call let_4
| let_5:
| | push (const id)
| | call let_3
| ret
call let_3
lift ($)
-let_1:
+let_6:
| push ()
| ret
+call let_6
+lift ($)
call let_1
lift ($)
-let_2:
-| push (const id)
-| let_4:
+let_7:
+| call let_4
+| let_2:
| | push (const id)
-| | call let_2
+| | call let_7
| | lift ($)
-| | call let_4
+| | call let_2
| | lift ($)
| | ret
-| call let_4
-| lift ($)
| call let_2
| lift ($)
+| call let_7
+| lift ($)
| ret
-call let_2
+call let_7
lift ($)
-call let_1
+call let_6
lift ($)
ret
push (const id)
-let_2:
+let_3:
| push ((flip ($)) () . (const id . (flip ($)) ()))
-| let_1:
+| let_2:
| | catch
| | <try>
| | | push ((.) . ((.) ((flip ($)) id) . const) id)
| | | read
| | | lift ($)
-| | | call let_1
+| | | call let_2
| | | lift ($)
| | | commit
| | | ret
| | | ret
| | <default>
| | fail
-| call let_1
+| call let_2
| lift ($)
| ret
-call let_2
+call let_3
lift ($)
-let_3:
+let_4:
| push ((flip ($)) Haskell)
-| let_4:
+| let_1:
| | catch
| | <try>
| | | tell
| | | read
| | | swap
| | | seek
-| | | choices [Haskell,Haskell,Haskell,Haskell,Haskell,Haskell,Haskell]
+| | | choices [(== Haskell),(== Haskell),(== Haskell),(== Haskell),(== Haskell),(== Haskell),(== Haskell)]
| | | <branch>
-| | | | push ((.) (.) . ((.) Haskell . (const . const Haskell)))
+| | | | push ((.) (.) . ((.) cons . (const . const Haskell)))
| | | | read
| | | | lift ($)
-| | | | call let_2
+| | | | call let_3
| | | | lift ($)
-| | | | call let_4
+| | | | call let_1
| | | | lift ($)
| | | | commit
| | | | ret
| | | <branch>
-| | | | push ((.) (.) . ((.) Haskell . (const . const Haskell)))
+| | | | push ((.) (.) . ((.) cons . (const . const Haskell)))
| | | | read
| | | | lift ($)
-| | | | call let_2
+| | | | call let_3
| | | | lift ($)
-| | | | call let_4
+| | | | call let_1
| | | | lift ($)
| | | | commit
| | | | ret
| | | <branch>
-| | | | push ((.) (.) . ((.) Haskell . (const . const Haskell)))
+| | | | push ((.) (.) . ((.) cons . (const . const Haskell)))
| | | | read
| | | | lift ($)
-| | | | call let_2
+| | | | call let_3
| | | | lift ($)
-| | | | call let_4
+| | | | call let_1
| | | | lift ($)
| | | | commit
| | | | ret
| | | <branch>
-| | | | push ((.) (.) . ((.) Haskell . (const . const Haskell)))
+| | | | push ((.) (.) . ((.) cons . (const . const Haskell)))
| | | | read
| | | | lift ($)
-| | | | call let_2
+| | | | call let_3
| | | | lift ($)
-| | | | call let_4
+| | | | call let_1
| | | | lift ($)
| | | | commit
| | | | ret
| | | <branch>
-| | | | push ((.) (.) . ((.) Haskell . (const . const Haskell)))
+| | | | push ((.) (.) . ((.) cons . (const . const Haskell)))
| | | | read
| | | | lift ($)
-| | | | call let_2
+| | | | call let_3
| | | | lift ($)
-| | | | call let_4
+| | | | call let_1
| | | | lift ($)
| | | | commit
| | | | ret
| | | <branch>
-| | | | push ((.) (.) . ((.) Haskell . (const . const Haskell)))
+| | | | push ((.) (.) . ((.) cons . (const . const Haskell)))
| | | | read
| | | | lift ($)
-| | | | call let_2
+| | | | call let_3
| | | | lift ($)
-| | | | call let_4
+| | | | call let_1
| | | | lift ($)
| | | | commit
| | | | ret
| | | <branch>
-| | | | push ((.) ((.) ((.) ((.) (.)))) . ((.) ((.) ((.) ((.) Haskell))) . ((.) ((.) ((.) const)) . ((.) ((.) ((flip ($)) (const Haskell))) . ((.) ((.) (.)) . ((.) ((.) const) . ((.) ((flip ($)) Haskell) . ((.) (.) . ((.) (const id) . const)))))))))
+| | | | push ((.) ((.) ((.) ((.) (.)))) . ((.) ((.) ((.) ((.) cons))) . ((.) ((.) ((.) const)) . ((.) ((.) ((flip ($)) (const Haskell))) . ((.) ((.) (.)) . ((.) ((.) const) . ((.) ((flip ($)) Haskell) . ((.) (.) . ((.) (const id) . const)))))))))
| | | | read
| | | | lift ($)
-| | | | call let_2
-| | | | lift ($)
| | | | call let_3
| | | | lift ($)
+| | | | call let_4
+| | | | lift ($)
| | | | read
| | | | lift ($)
-| | | | call let_2
+| | | | call let_3
| | | | lift ($)
-| | | | call let_4
+| | | | call let_1
| | | | lift ($)
| | | | commit
| | | | ret
| | | ret
| | <default>
| | fail
-| call let_4
+| call let_1
| lift ($)
| ret
-call let_3
+call let_4
lift ($)
ret
--- /dev/null
+push ((flip ($)) Haskell)
+let_1:
+| catch
+| <try>
+| | push ((.) . (cons . const Haskell))
+| | read
+| | lift ($)
+| | call let_1
+| | lift ($)
+| | commit
+| | ret
+| <handler>
+| tell
+| lift InstrPureSameOffset
+| choices [id]
+| <branch>
+| | push id
+| | ret
+| <default>
+| fail
+call let_1
+lift ($)
+ret
import Data.Eq (Eq)
import Data.Int (Int)
import Data.String (String)
-import Language.Haskell.TH (TExpQ)
import Prelude (undefined)
import Text.Show (Show)
import qualified Prelude
+import qualified Language.Haskell.TH as TH
import Symantic.Parser
-import qualified Symantic.Parser.Staging as Hask
+import qualified Symantic.Parser.Staging as H
data Expr = Var String | Num Int | Add Expr Expr deriving Show
data Asgn = Asgn String Expr deriving Show
m = bf <* item
-- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b
bf = match [char '>'] item op empty
- op (Hask.ValueCode '>' _) = string ">"
+ op (H.ValueCode '>' _) = string ">"
-}
--defuncTest = haskell Just <$> (haskell (+) <$> (item $> haskell 1) <*> (item $> haskell 8))
let goo = (-- newRegister_ unit (\r1 ->
let hoo = {-get r0 <~> get r1 *>-} goo *> hoo in hoo
) *> goo
- in goo) *> pure Hask.unit
+ in goo) *> pure H.unit
in foo *> foo
-haskell :: a -> TExpQ a -> Hask.Haskell a
-haskell e c = Hask.Haskell (Hask.ValueCode (Hask.Value e) (Hask.Code c))
+haskell :: a -> TH.CodeQ a -> H.Haskell a
+haskell e c = H.Haskell (H.ValueCode (H.Value e) c)
brainfuck :: Grammar repr => repr [BrainFuckOp]
brainfuck = whitespace *> bf
-- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b
bf = many (lexeme (match ((\c -> haskell c [||c||]) Prelude.<$> "><+-.,[") (look item) op empty))
-- op :: Pure repr Char -> repr BrainFuckOp
- op (Hask.Haskell (Hask.ValueCode (Hask.Value c) _)) = case c of
+ op (H.Haskell (H.ValueCode (H.Value c) _)) = case c of
'>' -> item $> haskell RightPointer [||RightPointer||]
'<' -> item $> haskell LeftPointer [||LeftPointer||]
'+' -> item $> haskell Increment [||Increment||]
| | ` pure id
| ` <*>
| + <*>
-| | + <*>
-| | | + pure const
-| | | ` pure id
-| | ` def let_3
+| | + def let_5
+| | | ` <*>
+| | | + pure const
+| | | ` pure id
+| | ` def let_7
| | ` <*>
| | + <*>
-| | | + <*>
-| | | | + pure const
-| | | | ` pure id
-| | | ` def let_5
+| | | + def let_1
+| | | | ` <*>
+| | | | + pure const
+| | | | ` pure id
+| | | ` def let_3
| | | ` <*>
| | | + <*>
| | | | + <*>
| | | | | + pure const
| | | | | ` pure id
-| | | | ` rec let_3
-| | | ` rec let_5
-| | ` rec let_3
-| ` def let_1
+| | | | ` rec let_7
+| | | ` rec let_3
+| | ` rec let_7
+| ` def let_2
| ` pure ()
` <*>
+ <*>
- | + <*>
- | | + pure const
- | | ` pure id
- | ` def let_2
+ | + ref let_5
+ | ` def let_4
| ` <*>
| + <*>
- | | + <*>
- | | | + pure const
- | | | ` pure id
- | | ` def let_4
+ | | + ref let_1
+ | | ` def let_6
| | ` <*>
| | + <*>
| | | + <*>
| | | | + pure const
| | | | ` pure id
- | | | ` rec let_2
- | | ` rec let_4
- | ` rec let_2
- ` ref let_1
+ | | | ` rec let_4
+ | | ` rec let_6
+ | ` rec let_4
+ ` ref let_2
+ <*>
| + <*>
| | + <*>
-| | | + pure ((.) ((flip ($)) (const id)) . ((.) (.) . ((.) (.) . ((.) (const id) . const id))))
-| | | ` def let_5
-| | | ` <*>
-| | | + <*>
-| | | | + pure (const id)
-| | | | ` def let_2
-| | | | ` <*>
-| | | | + <*>
-| | | | | + pure (const id)
-| | | | | ` rec let_5
-| | | | ` rec let_2
-| | | ` rec let_5
-| | ` def let_3
-| | ` pure ()
+| | | + <*>
+| | | | + <*>
+| | | | | + pure ((.) ((.) (.)) . ((.) ((.) (.)) . (.) ((.) (const id))))
+| | | | | ` def let_5
+| | | | | ` pure (const id)
+| | | | ` def let_7
+| | | | ` <*>
+| | | | + <*>
+| | | | | + def let_1
+| | | | | | ` pure (const id)
+| | | | | ` def let_3
+| | | | | ` <*>
+| | | | | + <*>
+| | | | | | + pure (const id)
+| | | | | | ` rec let_7
+| | | | | ` rec let_3
+| | | | ` rec let_7
+| | | ` def let_2
+| | | ` pure ()
+| | ` ref let_5
| ` def let_4
| ` <*>
| + <*>
-| | + pure (const id)
-| | ` def let_1
+| | + ref let_1
+| | ` def let_6
| | ` <*>
| | + <*>
| | | + pure (const id)
| | | ` rec let_4
-| | ` rec let_1
+| | ` rec let_6
| ` rec let_4
-` ref let_3
+` ref let_2
| + <*>
| | + pure const
| | ` pure id
-| ` def let_1
+| ` def let_2
| ` <*>
| + <*>
| | + <*>
| | | | + <*>
| | | | | + pure flip
| | | | | ` pure const
-| | | | ` def let_2
+| | | | ` def let_1
| | | | ` satisfy
| | | ` rec let_5
| | ` pure id
| | + <*>
| | | + pure (.)
| | | ` <*>
- | | | + pure Haskell
+ | | | + pure cons
| | | ` <*>
| | | + <*>
| | | | + pure const
| | | | | | + <*>
| | | | | | | + pure const
| | | | | | | ` pure Haskell
- | | | | | | ` ref let_2
+ | | | | | | ` ref let_1
| | | | | + <*>
| | | | | | + <*>
| | | | | | | + pure const
| | | | | | | ` pure Haskell
- | | | | | | ` ref let_2
+ | | | | | | ` ref let_1
| | | | | + <*>
| | | | | | + <*>
| | | | | | | + pure const
| | | | | | | ` pure Haskell
- | | | | | | ` ref let_2
+ | | | | | | ` ref let_1
| | | | | + <*>
| | | | | | + <*>
| | | | | | | + pure const
| | | | | | | ` pure Haskell
- | | | | | | ` ref let_2
+ | | | | | | ` ref let_1
| | | | | + <*>
| | | | | | + <*>
| | | | | | | + pure const
| | | | | | | ` pure Haskell
- | | | | | | ` ref let_2
+ | | | | | | ` ref let_1
| | | | | + <*>
| | | | | | + <*>
| | | | | | | + pure const
| | | | | | | ` pure Haskell
- | | | | | | ` ref let_2
+ | | | | | | ` ref let_1
| | | | | ` <*>
| | | | | + <*>
| | | | | | + pure const
| | | | | | | ` <*>
| | | | | | | + <*>
| | | | | | | | + pure const
- | | | | | | | | ` ref let_2
- | | | | | | | ` ref let_1
+ | | | | | | | | ` ref let_1
+ | | | | | | | ` ref let_2
| | | | | | ` <*>
| | | | | | + pure Haskell
| | | | | | ` rec let_3
| | | | | + <*>
| | | | | | + pure const
| | | | | | ` pure Haskell
- | | | | | ` ref let_2
+ | | | | | ` ref let_1
| | | | + look
- | | | | | ` ref let_2
+ | | | | | ` ref let_1
| | | | ` empty
- | | | ` ref let_1
+ | | | ` ref let_2
| | ` rec let_4
| ` pure id
` pure Haskell
<*>
+ <*>
| + pure (const id)
-| ` def let_4
+| ` def let_1
| ` <*>
| + pure ((flip ($)) () . (const id . (flip ($)) ()))
-| ` def let_3
+| ` def let_4
| ` <|>
| + <*>
| | + <*>
| | | + pure ((.) . ((.) ((flip ($)) id) . const) id)
| | | ` satisfy
-| | ` rec let_3
+| | ` rec let_4
| ` pure id
-` def let_1
+` def let_2
` <*>
+ pure ((flip ($)) Haskell)
- ` def let_2
+ ` def let_3
` <|>
+ <*>
| + <*>
| | + conditional
| | | + bs
| | | | + <*>
- | | | | | + pure ((.) (.) . ((.) Haskell . (const . const Haskell)))
+ | | | | | + pure ((.) (.) . ((.) cons . (const . const Haskell)))
| | | | | ` satisfy
| | | | + <*>
- | | | | | + pure ((.) (.) . ((.) Haskell . (const . const Haskell)))
+ | | | | | + pure ((.) (.) . ((.) cons . (const . const Haskell)))
| | | | | ` satisfy
| | | | + <*>
- | | | | | + pure ((.) (.) . ((.) Haskell . (const . const Haskell)))
+ | | | | | + pure ((.) (.) . ((.) cons . (const . const Haskell)))
| | | | | ` satisfy
| | | | + <*>
- | | | | | + pure ((.) (.) . ((.) Haskell . (const . const Haskell)))
+ | | | | | + pure ((.) (.) . ((.) cons . (const . const Haskell)))
| | | | | ` satisfy
| | | | + <*>
- | | | | | + pure ((.) (.) . ((.) Haskell . (const . const Haskell)))
+ | | | | | + pure ((.) (.) . ((.) cons . (const . const Haskell)))
| | | | | ` satisfy
| | | | + <*>
- | | | | | + pure ((.) (.) . ((.) Haskell . (const . const Haskell)))
+ | | | | | + pure ((.) (.) . ((.) cons . (const . const Haskell)))
| | | | | ` satisfy
| | | | ` <*>
| | | | + <*>
| | | | | + <*>
| | | | | | + <*>
- | | | | | | | + pure ((.) ((.) ((.) ((.) (.)))) . ((.) ((.) ((.) ((.) Haskell))) . ((.) ((.) ((.) const)) . ((.) ((.) ((flip ($)) (const Haskell))) . ((.) ((.) (.)) . ((.) ((.) const) . ((.) ((flip ($)) Haskell) . ((.) (.) . ((.) (const id) . const)))))))))
+ | | | | | | | + pure ((.) ((.) ((.) ((.) (.)))) . ((.) ((.) ((.) ((.) cons))) . ((.) ((.) ((.) const)) . ((.) ((.) ((flip ($)) (const Haskell))) . ((.) ((.) (.)) . ((.) ((.) const) . ((.) ((flip ($)) Haskell) . ((.) (.) . ((.) (const id) . const)))))))))
| | | | | | | ` satisfy
- | | | | | | ` ref let_4
- | | | | | ` rec let_1
+ | | | | | | ` ref let_1
+ | | | | | ` rec let_2
| | | | ` satisfy
| | | + look
| | | | ` satisfy
| | | ` empty
- | | ` ref let_4
- | ` rec let_2
+ | | ` ref let_1
+ | ` rec let_3
` pure id
--- /dev/null
+<*>
++ def let_1
+| ` <|>
+| + <*>
+| | + <*>
+| | | + pure (.)
+| | | ` <*>
+| | | + pure cons
+| | | ` <*>
+| | | + <*>
+| | | | + pure const
+| | | | ` pure Haskell
+| | | ` satisfy
+| | ` rec let_1
+| ` pure id
+` pure Haskell
--- /dev/null
+<*>
++ pure ((flip ($)) Haskell)
+` def let_1
+ ` <|>
+ + <*>
+ | + <*>
+ | | + pure ((.) . (cons . const Haskell))
+ | | ` satisfy
+ | ` rec let_1
+ ` pure id
sourcephile / git / haskell / symantic-parser.git / commitdiff