--- /dev/null
+{ pkgs ? import <nixpkgs> {}
+, ghc ? null
+}:
+let
+ haskellPackages =
+ if ghc == null
+ then pkgs.haskellPackages
+ else pkgs.haskell.packages.${ghc};
+ hs = haskellPackages.extend (with pkgs.haskell.lib;
+ packageSourceOverrides {
+ symantic-parser = ./.;
+ }
+ );
+in hs.symantic-parser // {
+ shell = hs.shellFor {
+ packages = p: [ p.symantic-parser ];
+ nativeBuildInputs = [
+ hs.cabal-install
+ hs.hie
+ ];
+ buildInputs = [
+ #hs.ghcid
+ hs.ormolu
+ hs.hlint
+ #pkgs.nixpkgs-fmt
+ ];
+ #withHoogle = true;
+ };
+}
--- /dev/null
+{
+ "nodes": {
+ "all-hies": {
+ "flake": false,
+ "locked": {
+ "lastModified": 1597070901,
+ "narHash": "sha256-IgZ/SSxfDXYEcl/vKOEQRaMiARVy9mWzbQGuzi+lgS8=",
+ "owner": "infinisil",
+ "repo": "all-hies",
+ "rev": "534ac517b386821b787d1edbd855b9966d0c0775",
+ "type": "github"
+ },
+ "original": {
+ "owner": "infinisil",
+ "repo": "all-hies",
+ "type": "github"
+ }
+ },
+ "flake-utils": {
+ "locked": {
+ "lastModified": 1601282935,
+ "narHash": "sha256-WQAFV6sGGQxrRs3a+/Yj9xUYvhTpukQJIcMbIi7LCJ4=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "588973065fce51f4763287f0fda87a174d78bf48",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "nixpkgs": {
+ "locked": {
+ "narHash": "sha256-QD8y4XCl1aZ6SWWtIUyuF7OsRwSfcw/2zoXS0LFPb6s=",
+ "path": "/nix/store/hlxc12hk8gl24fml3n7q9xlrr78cqf1r-nixpkgs-patched",
+ "type": "path"
+ },
+ "original": {
+ "id": "nixpkgs",
+ "type": "indirect"
+ }
+ },
+ "nixpkgs-2003": {
+ "locked": {
+ "lastModified": 1601475821,
+ "narHash": "sha256-7AI8j/xq5slauMGwC3Dp2K9TKDyDtBXBebeyWsE9euE=",
+ "owner": "nixos",
+ "repo": "nixpkgs",
+ "rev": "b4db68ff563895eea6aab4ff24fa04ef403dfe14",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nixos",
+ "ref": "nixos-20.03",
+ "repo": "nixpkgs",
+ "type": "github"
+ }
+ },
+ "root": {
+ "inputs": {
+ "all-hies": "all-hies",
+ "flake-utils": "flake-utils",
+ "nixpkgs": "nixpkgs",
+ "nixpkgs-2003": "nixpkgs-2003"
+ }
+ }
+ },
+ "root": "root",
+ "version": 7
+}
--- /dev/null
+{
+# Update inputs with:
+# nix flake update --recreate-lock-file
+inputs.nixpkgs.url = "flake:nixpkgs";
+# This is needed until all-hies supports glibc-2.31
+inputs.nixpkgs-2003.url = "github:nixos/nixpkgs/nixos-20.03";
+inputs.flake-utils.url = "github:numtide/flake-utils";
+#inputs.haskell-nix.url = "github:input-output-hk/haskell.nix";
+inputs.all-hies.url = "github:infinisil/all-hies";
+inputs.all-hies.flake = false;
+outputs = inputs: let
+ in inputs.flake-utils.lib.eachDefaultSystem (system: let
+ pkgs = inputs.nixpkgs.legacyPackages.${system};
+ /*
+ projectName = "symantic-parser";
+ pkgs = import inputs.haskell-nix.sources.nixpkgs (inputs.haskell-nix.nixpkgsArgs // {
+ localSystem = { inherit system; };
+ overlays = inputs.haskell-nix.nixpkgsArgs.overlays ++ [
+ (import inputs.all-hies {}).overlay
+ ];
+ });
+ compiler-nix-name = "ghc865";
+ project = pkgs.haskell-nix.cabalProject {
+ src = pkgs.haskell-nix.haskellLib.cleanGit {
+ name = projectName;
+ src = ./.;
+ };
+ inherit compiler-nix-name;
+ #index-state = "2020-08-31T00:00:00Z";
+ # To be kept up to date with source-repository-package entries in cabal.project
+ sha256map = {
+ };
+ # Update by commenting materialized and running:
+ # nix run .#materialize
+ #materialized = ./plan-nix;
+ };
+ */
+ in {
+ defaultPackage = import ./default.nix { inherit pkgs; };
+ devShell = (import ./default.nix {
+ ghc = "ghc883";
+ pkgs = import inputs.nixpkgs-2003 {
+ inherit system;
+ overlays = [
+ (import inputs.all-hies {}).overlay
+ /*
+ (self: super: {
+ inherit (inputs.nixpkgs-2003.legacyPackages.${system}) glibc texinfo gmp;
+ glibc = super.glibc.overrideAttrs (_: rec {
+ name = "glibc-${version}";
+ version = "2.30";
+ src = pkgs.fetchurl {
+ url = "mirror://gnu/glibc/glibc-${version}.tar.xz";
+ inherit sha256;
+ };
+ });
+ })
+ */
+ ];
+ };
+ }).shell;
+ /*
+ # Build with: nix build
+ defaultPackage = project.${projectName}.components.exes."playground";
+ #packages.${projectName} = project;
+ # Run with: nix run .#benchmarks
+ apps."benchmarks" = {
+ type = "app";
+ program = "${project.${projectName}.components.exes."benchmarks"}/bin/benchmarks";
+ };
+ # Run with: nix run .#playground
+ apps."playground" = {
+ type = "app";
+ program = "${inputs.self.defaultPackage.${system}}/bin/playground";
+ };
+ # Run with: nix run .#materialize
+ apps.materialize = {
+ type = "app";
+ program = (pkgs.writeShellScript "materialize" ''
+ ${pkgs.rsync}/bin/rsync --delete -ai ${project.plan-nix}/ plan-nix/
+ '').outPath;
+ };
+ # Run with: nix run .#register
+ apps.register = {
+ type = "app";
+ program = (pkgs.writeShellScript "register" ''
+ set -x
+ nix-store --add-root nix.root --indirect --realise ${project.roots}
+ '').outPath;
+ };
+ # Get a development environment with: nix shell
+ devShell = project.shellFor {
+ packages = hpkgs: [
+ hpkgs."${projectName}"
+ ];
+ #components = hpkgs: [];
+ #additional = hpkgs: [];
+ withHoogle = false;
+ tools = {
+ cabal = "3.2.0.0";
+ #hie = "unstable";
+ #hlint = "2.2.11";
+ };
+ builtInputs = with project.haskellPackages; [
+ ];
+ exactDeps = true;
+ shellHook = ''
+ nix-store --add-root nix.root --indirect --realise ${project.roots}
+ '';
+ };
+ */
+ }
+ );
+}
--- /dev/null
+(import ./. {}).shell
, module Symantic.Parser
) where
import Symantic.Parser.Grammar
-import qualified Symantic.Parser.Staging as S
+import qualified Symantic.Parser.Staging as Hask
--import Prelude hiding (fmap, pure, (<*), (*>), (<*>), (<$>), (<$), pred, repeat)
import Data.Int (Int)
-import Data.Char (Char)
+-- import Data.Char (Char)
+import Prelude (undefined)
import Data.String (String)
import Text.Show (Show)
import Data.Eq (Eq)
-import Control.Monad (liftM)
-import Data.Char (isAlpha, isAlphaNum, isSpace, isUpper, isDigit, digitToInt, chr, ord)
-import Data.Set (fromList, member)
-import Data.Maybe (catMaybes)
-import Text.Read (readMaybe)
+-- import Control.Monad (liftM)
+-- import Data.Char (isAlpha, isAlphaNum, isSpace, isUpper, isDigit, digitToInt, chr, ord)
+-- import Data.Set (fromList, member)
+-- import Data.Maybe (catMaybes)
+-- import Text.Read (readMaybe)
import Language.Haskell.TH (TExpQ)
import qualified Prelude
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 (S.Runtime '>' _) = string ">"
+ op (Hask.Runtime '>' _) = string ">"
-}
--defuncTest = runtime Just <$> (runtime (+) <$> (item $> runtime 1) <*> (item $> runtime 8))
let goo = (-- newRegister_ unit (\r1 ->
let hoo = {-get r0 <~> get r1 *>-} goo *> hoo in hoo
) *> goo
- in goo) *> pure S.unit
+ in goo) *> pure Hask.unit
in foo *> foo
-runtime :: a -> TExpQ a -> S.Runtime a
-runtime e c = S.Runtime (S.Eval e) (S.Code c)
+runtime :: a -> TExpQ a -> Hask.Runtime a
+runtime e c = Hask.Runtime (Hask.Eval e) (Hask.Code c)
brainfuck ::
forall repr.
bf :: repr [BrainFuckOp]
bf = many (lexeme (match ((\c -> runtime c [||c||]) Prelude.<$> "><+-.,[") (look item) op empty))
-- op :: Pure repr Char -> repr BrainFuckOp
- op (S.Runtime (S.Eval c) _) = case c of
+ op (Hask.Runtime (Hask.Eval c) _) = case c of
'>' -> item $> runtime RightPointer [||RightPointer||]
'<' -> item $> runtime LeftPointer [||LeftPointer||]
'+' -> item $> runtime Increment [||Increment||]
'.' -> item $> runtime Output [||Output||]
',' -> item $> runtime Input [||Input||]
'[' -> between (lexeme item) (char ']') (runtime Loop [||Loop||] <$> bf)
+ _ -> undefined
--- /dev/null
+module Symantic.Parser.Automaton
+ ( module Symantic.Parser.Automaton.Instructions
+ ) where
+import Symantic.Parser.Automaton.Instructions
--- /dev/null
+module Symantic.Parser.Automaton.Instructions where
+
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Int (Int)
-import Data.Kind (Type)
+-- import Data.Kind (Type)
import Data.Maybe (Maybe(..))
import Data.String (String)
import Language.Haskell.TH (TExpQ)
-import qualified Data.Functor as F
+-- import qualified Data.Functor as F
import qualified Prelude as Pre
import qualified Data.List as List
import Symantic.Base.Univariant
-import qualified Symantic.Parser.Staging as S
+import qualified Symantic.Parser.Staging as Hask
-- * Class 'Applicable'
class Applicable repr where
- (<$>) :: S.Runtime (a -> b) -> repr a -> repr b
+ (<$>) :: Hask.Runtime (a -> b) -> repr a -> repr b
(<$>) f = (pure f <*>)
- (<&>) :: repr a -> S.Runtime (a -> b) -> repr b
+ (<&>) :: repr a -> Hask.Runtime (a -> b) -> repr b
(<&>) = flip (<$>)
- (<$) :: S.Runtime a -> repr b -> repr a
+ (<$) :: Hask.Runtime a -> repr b -> repr a
(<$) x = (pure x <*)
- ($>) :: repr a -> S.Runtime b -> repr b
+ ($>) :: repr a -> Hask.Runtime b -> repr b
($>) = flip (<$)
--type Pure repr :: Type -> Type
- pure :: S.Runtime a -> repr a
+ pure :: Hask.Runtime a -> repr a
default pure ::
Liftable repr => Applicable (Unlift repr) =>
- S.Runtime a -> repr a
+ Hask.Runtime a -> repr a
pure = lift . pure
(<*>) :: repr (a -> b) -> repr a -> repr b
repr (a -> b) -> repr a -> repr b
(<*>) = lift2 (<*>)
- liftA2 :: S.Runtime (a -> b -> c) -> repr a -> repr b -> repr c
+ liftA2 :: Hask.Runtime (a -> b -> c) -> repr a -> repr b -> repr c
liftA2 f x = (<*>) (f <$> x)
(*>) :: repr a -> repr b -> repr b
- x *> y = (S.id <$ x) <*> y
+ x *> y = (Hask.id <$ x) <*> y
(<*) :: repr a -> repr b -> repr a
- (<*) = liftA2 S.const
+ (<*) = liftA2 Hask.const
{-
(<**>) :: repr a -> repr (a -> b) -> repr b
infixl 4 <**>
(<**>) :: Applicable repr => repr a -> repr (a -> b) -> repr b
-(<**>) = liftA2 (S.flip S..@ (S.$))
+(<**>) = liftA2 (Hask.flip Hask..@ (Hask.$))
-- * Class 'Alternable'
class Alternable repr where
infixl 3 <+>
(<+>) :: Applicable repr => Alternable repr => repr a -> repr b -> repr (Either a b)
-p <+> q = S.Runtime (S.Eval Left) (S.Code [||Left||]) <$> p <|>
- S.Runtime (S.Eval Right) (S.Code [||Right||]) <$> q
+p <+> q = Hask.Runtime (Hask.Eval Left) (Hask.Code [||Left||]) <$> p <|>
+ Hask.Runtime (Hask.Eval Right) (Hask.Code [||Right||]) <$> q
-optionally :: Applicable repr => Alternable repr => repr a -> S.Runtime b -> repr b
+optionally :: Applicable repr => Alternable repr => repr a -> Hask.Runtime b -> repr b
optionally p x = p $> x <|> pure x
optional :: Applicable repr => Alternable repr => repr a -> repr ()
-optional = flip optionally S.unit
+optional = flip optionally Hask.unit
-option :: Applicable repr => Alternable repr => S.Runtime a -> repr a -> repr a
+option :: Applicable repr => Alternable repr => Hask.Runtime a -> repr a -> repr a
option x p = p <|> pure x
choice :: Alternable repr => [repr a] -> repr a
choice = List.foldr (<|>) empty
maybeP :: Applicable repr => Alternable repr => repr a -> repr (Maybe a)
-maybeP p = option (S.Runtime (S.Eval Nothing) (S.Code [||Nothing||]))
- (S.Runtime (S.Eval Just) (S.Code [||Just||]) <$> p)
+maybeP p = option (Hask.Runtime (Hask.Eval Nothing) (Hask.Code [||Nothing||]))
+ (Hask.Runtime (Hask.Eval Just) (Hask.Code [||Just||]) <$> p)
manyTill :: Applicable repr => Alternable repr => repr a -> repr b -> repr [a]
-manyTill p end = let go = end $> S.nil <|> p <:> go in go
+manyTill p end = let go = end $> Hask.nil <|> p <:> go in go
-- * Class 'Selectable'
class Selectable repr where
default branch ::
Liftable repr => Selectable (Unlift repr) =>
repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
- branch = lift3 branch
+ branch = lift3 branch
class Matchable repr where
conditional ::
- Eq a => [S.Runtime (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
+ Eq a => [Hask.Runtime (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
default conditional ::
Unliftable repr => Liftable repr => Matchable (Unlift repr) =>
- Eq a => [S.Runtime (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
+ Eq a => [Hask.Runtime (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
conditional cs bs = lift2 (conditional cs (unlift Pre.<$> bs))
- match :: Eq a => [S.Runtime a] -> repr a -> (S.Runtime a -> repr b) -> repr b -> repr b
- match as a a2b b = conditional (S.eq Pre.<$> as) (a2b Pre.<$> as) a b
+ match :: Eq a => [Hask.Runtime a] -> repr a -> (Hask.Runtime a -> repr b) -> repr b -> repr b
+ match as a a2b = conditional (Hask.eq Pre.<$> as) (a2b Pre.<$> as) a
-- * Class 'Foldable'
class Foldable repr where
chainPost = lift2 chainPost
{-
-conditional :: Selectable repr => [(S.Runtime (a -> Bool), repr b)] -> repr a -> repr b -> repr b
+conditional :: Selectable repr => [(Hask.Runtime (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 :: S.Runtime (Char -> Bool) -> repr Char
+ satisfy :: Hask.Runtime (Char -> Bool) -> repr Char
default satisfy ::
Liftable repr => Charable (Unlift repr) =>
- S.Runtime (Char -> Bool) -> repr Char
+ Hask.Runtime (Char -> Bool) -> repr Char
satisfy = lift . satisfy
-- * Class 'Lookable'
class Lookable repr where
look :: repr a -> repr a
negLook :: repr a -> repr ()
- default look :: Liftable repr => Lookable (Unlift repr) => repr a -> repr a
+ default look :: Liftable repr => Lookable (Unlift repr) => repr a -> repr a
default negLook :: Liftable repr => Lookable (Unlift repr) => repr a -> repr ()
- look = lift1 look
+ look = lift1 look
negLook = lift1 negLook
{-# INLINE (<:>) #-}
infixl 4 <:>
(<:>) :: Applicable repr => repr a -> repr [a] -> repr [a]
-(<:>) = liftA2 S.cons
+(<:>) = liftA2 Hask.cons
sequence :: Applicable repr => [repr a] -> repr [a]
-sequence = List.foldr (<:>) (pure S.nil)
+sequence = List.foldr (<:>) (pure Hask.nil)
traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
traverse f = sequence . List.map f
-- oneOf :: [Char] -> repr Char
-- oneOf cs = satisfy (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])
-noneOf :: Charable repr => [Char] -> repr Char
-noneOf cs = satisfy ((S.Runtime (S.Eval (not . flip List.elem cs)) (S.Code [||\c -> not $$(ofChars cs [||c||])||])))
+noneOf :: Charable repr => String -> repr Char
+noneOf cs = satisfy (Hask.Runtime (Hask.Eval (not . flip List.elem cs)) (Hask.Code [||\c -> not $$(ofChars cs [||c||])||]))
-ofChars :: [Char] -> TExpQ Char -> TExpQ Bool
+ofChars :: String -> TExpQ Char -> TExpQ 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 (S.eq (S.char c)) $> S.char c
+char c = satisfy (Hask.eq (Hask.char c)) $> Hask.char c
item :: Charable repr => repr Char
-item = satisfy (S.const S..@ S.bool True)
+item = satisfy (Hask.const Hask..@ Hask.bool True)
-- Composite Combinators
-- someTill :: repr a -> repr b -> repr [a]
void p = p *> unit
unit :: Applicable repr => repr ()
-unit = pure S.unit
+unit = pure Hask.unit
{-
constp :: Applicable repr => repr a -> repr (b -> a)
-constp = (S.const <$>)
+constp = (Hask.const <$>)
-- Alias Operations
infixl 4 <~>
(<~>) :: Applicable repr => repr a -> repr b -> repr (a, b)
-(<~>) = liftA2 (S.runtime (,))
+(<~>) = liftA2 (Hask.runtime (,))
infixl 4 <~
(<~) :: Applicable repr => repr a -> repr b -> repr a
-- Lift Operations
liftA2 ::
Applicable repr =>
- S.Runtime (a -> b -> c) -> repr a -> repr b -> repr c
+ Hask.Runtime (a -> b -> c) -> repr a -> repr b -> repr c
liftA2 f x = (<*>) (fmap f x)
liftA3 ::
Applicable repr =>
- S.Runtime (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
+ Hask.Runtime (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 =>
- S.Runtime (a -> b -> b) -> S.Runtime b -> repr a -> repr b
+ Hask.Runtime (a -> b -> b) -> Hask.Runtime b -> repr a -> repr b
pfoldr f k p = chainPre (f <$> p) (pure k)
pfoldr1 ::
Applicable repr => Foldable repr =>
- S.Runtime (a -> b -> b) -> S.Runtime b -> repr a -> repr b
+ Hask.Runtime (a -> b -> b) -> Hask.Runtime b -> repr a -> repr b
pfoldr1 f k p = f <$> p <*> pfoldr f k p
pfoldl ::
Applicable repr => Foldable repr =>
- S.Runtime (b -> a -> b) -> S.Runtime b -> repr a -> repr b
-pfoldl f k p = chainPost (pure k) ((S.flip <$> pure f) <*> p)
+ Hask.Runtime (b -> a -> b) -> Hask.Runtime b -> repr a -> repr b
+pfoldl f k p = chainPost (pure k) ((Hask.flip <$> pure f) <*> p)
pfoldl1 ::
Applicable repr => Foldable repr =>
- S.Runtime (b -> a -> b) -> S.Runtime b -> repr a -> repr b
-pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((S.flip <$> pure f) <*> p)
+ Hask.Runtime (b -> a -> b) -> Hask.Runtime b -> repr a -> repr b
+pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Hask.flip <$> pure f) <*> p)
-- Chain Combinators
chainl1' ::
Applicable repr => Foldable repr =>
- S.Runtime (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
-chainl1' f p op = chainPost (f <$> p) (S.flip <$> op <*> p)
+ Hask.Runtime (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
+chainl1' f p op = chainPost (f <$> p) (Hask.flip <$> op <*> p)
chainl1 ::
Applicable repr => Foldable repr =>
repr a -> repr (a -> a -> a) -> repr a
-chainl1 = chainl1' S.id
+chainl1 = chainl1' Hask.id
{-
chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
-chainr1' f p op = newRegister_ S.id $ \acc ->
+chainr1' f p op = newRegister_ Hask.id $ \acc ->
let go = bind p $ \x ->
- modify acc (S.flip (S..@) <$> (op <*> x)) *> go
+ modify acc (Hask.flip (Hask..@) <$> (op <*> x)) *> go
<|> f <$> x
in go <**> get acc
chainr1 :: repr a -> repr (a -> a -> a) -> repr a
-chainr1 = chainr1' S.id
+chainr1 = chainr1' Hask.id
-chainr :: repr a -> repr (a -> a -> a) -> S.Runtime a -> repr a
+chainr :: repr a -> repr (a -> a -> a) -> Hask.Runtime 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) -> S.Runtime a -> repr a
+ repr a -> repr (a -> a -> a) -> Hask.Runtime 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 S.cons S.nil
+many = pfoldr Hask.cons Hask.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 S.const S.unit -- the void here will encourage the optimiser to recognise that the register is unused
+skipMany = void . pfoldl Hask.const Hask.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 S.nil (sepBy1 p sep)
+sepBy p sep = option Hask.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 S.nil (sepEndBy1 p sep)
+sepEndBy p sep = option Hask.nil (sepEndBy1 p sep)
sepEndBy1 ::
Applicable repr => Alternable repr => Foldable repr =>
repr a -> repr b -> repr [a]
sepEndBy1 p sep =
- let seb1 = p <**> (sep *> (S.flip S..@ S.cons <$> option S.nil seb1)
- <|> pure (S.flip S..@ S.cons S..@ S.nil))
+ let seb1 = p <**> (sep *> (Hask.flip Hask..@ Hask.cons <$> option Hask.nil seb1)
+ <|> pure (Hask.flip Hask..@ Hask.cons Hask..@ Hask.nil))
in seb1
{-
sepEndBy1 :: repr a -> repr b -> repr [a]
-sepEndBy1 p sep = newRegister_ S.id $ \acc ->
- let go = modify acc ((S.flip (S..)) S..@ S.cons <$> p)
+sepEndBy1 p sep = newRegister_ Hask.id $ \acc ->
+ let go = modify acc ((Hask.flip (Hask..)) Hask..@ Hask.cons <$> p)
*> (sep *> (go <|> get acc) <|> get acc)
- in go <*> pure S.nil
+ in go <*> pure Hask.nil
-}
--- /dev/null
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+module Symantic.Parser.Grammar.Observations where
+
+import Control.Monad (Monad(..), mapM_, when)
+-- import Data.String (String)
+-- import Data.Array (Ix)
+-- import Data.Bool
+-- import Data.Dependent.Map (DMap)
+import Data.Eq (Eq(..))
+import Data.Function (($), id)
+import Data.Functor (Functor(..))
+-- import Data.Functor.Identity (Identity(..))
+-- import Data.GADT.Compare (GEq, GCompare, gcompare, geq, GOrdering(..))
+import Data.HashMap.Strict (HashMap)
+import Data.HashSet (HashSet)
+import Data.Hashable (Hashable, hashWithSalt, hash)
+-- import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+-- import Data.Kind (Type)
+-- import Data.Functor.Constant (Constant(..))
+-- import Data.Functor.Compose (Compose(..))
+import Data.Maybe (Maybe(..), isNothing, maybe)
+import Data.Monoid (Monoid(..))
+import Data.Ord (Ord(..))
+-- import Data.Set (Set, foldr)
+-- import Data.Typeable ((:~:)(Refl))
+-- import Data.Word (Word64)
+-- import Debug.Trace (trace)
+import GHC.Exts (Int(..))
+import GHC.Prim (StableName#, unsafeCoerce#)
+import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)
+import Numeric (showHex)
+import Prelude ((+))
+-- import Prelude (Num(..), Enum(..))
+import System.IO.Unsafe (unsafePerformIO)
+import Text.Show (Show(..))
+-- import Unsafe.Coerce (unsafeCoerce)
+-- import Prelude (undefined)
+import qualified Control.Monad.Trans.Class as T
+import qualified Control.Monad.Trans.Reader as R
+-- import qualified Control.Monad.Trans.Writer as W
+import qualified Control.Monad.Trans.State as S
+
+-- import qualified Data.Dependent.Map as DMap
+import qualified Data.HashMap.Strict as HM
+import qualified Data.HashSet as HS
+--import qualified Data.Map as Map
+--import qualified Data.Set as Set
+
+import Symantic.Base.Univariant
+import qualified Symantic.Parser.Grammar.Combinators as P
+--import qualified Symantic.Parser.Staging as P
+
+{-
+newtype IMVar = IMVar Word64 deriving newtype (Ord, Eq, Num, Enum, Show, Ix)
+newtype MVar (a :: Type) = MVar IMVar
+instance Show (MVar a) where show (MVar m) = "m" <> show m
+
+instance GEq MVar where
+ geq (MVar u) (MVar v)
+ | u == v = Just (unsafeCoerce Refl)
+ | otherwise = Nothing
+instance GCompare MVar where
+ gcompare m1@(MVar u) m2@(MVar v) =
+ case compare u v of
+ LT -> GLT
+ EQ -> case geq m1 m2 of Just Refl -> GEQ
+ GT -> GGT
+-}
+
+-- * Type 'ParserName'
+data ParserName = forall a. ParserName (StableName# a)
+makeParserName :: repr a -> ParserName
+-- Force evaluation of p to ensure that the stableName is correct first time
+makeParserName !p = unsafePerformIO $ fmap (\(StableName name) -> ParserName name) (makeStableName p)
+instance Eq ParserName where
+ (ParserName n) == (ParserName m) = eqStableName (StableName n) (StableName m)
+instance Hashable ParserName where
+ hash (ParserName n) = hashStableName (StableName n)
+ hashWithSalt salt (ParserName n) = hashWithSalt salt (StableName n)
+
+instance Show ParserName where showsPrec _ (ParserName n) = showHex (I# (unsafeCoerce# n))
+
+-- * Type 'Lets'
+-- | Interpret combinators as 'ParserName'
+newtype Lets a = Lets { unLets :: R.ReaderT (HashSet ParserName) (S.State LetsState) () }
+
+lets :: Lets a -> (HashSet ParserName, HashSet ParserName)
+lets (Lets m) =
+ let st = S.execState (R.runReaderT m mempty) emptyLetsState in
+ ( HM.keysSet (HM.filter (> 1) (lets_preds st))
+ , lets_recs st
+ )
+
+letsNode :: Lets a -> Lets a
+letsNode (Lets m) = Lets $ do
+ let name = makeParserName m
+ st <- T.lift S.get
+ let (before, preds) = HM.alterF (\v -> (v, Just (maybe 1 (+ 1) v))) name (lets_preds st)
+ seen <- R.ask
+ if --trace (ind<>"at: "<>show name) $
+ HS.member name seen
+ then --trace (ind<>"skipR: "<>show name) $
+ T.lift $ S.put st
+ { lets_preds = preds
+ , lets_recs = HS.insert name (lets_recs st)
+ }
+ else do
+ T.lift $ S.put st{ lets_preds = preds }
+ when (isNothing before) $
+ R.local (HS.insert name) m
+ {-
+ if trace (ind<>"b?: "<>show name) $ before /= Nothing
+ then trace (ind<>"SKIPB: "<>show name) $ return ()
+ else trace (ind<>"first: "<>show name) $
+ R.local (\(m,i) -> (HS.insert name m, ind<>" ")) r
+ -}
+
+-- | This is an uncommon 'Unlift' definition which unlifts nothing,
+-- but it enables to leverage default definitions.
+type instance Unlift Lets = Lets
+instance Liftable Lets where
+ lift _x = letsNode (Lets (return ()))
+ lift1 _f x = letsNode (Lets (unLets x))
+ lift2 _f x y = letsNode (Lets (unLets x >> unLets y))
+ lift3 _f x y z = letsNode (Lets (unLets x >> unLets y >> unLets z))
+instance Unliftable Lets where
+ unlift = id
+instance P.Applicable Lets
+instance P.Alternable Lets
+instance P.Selectable Lets
+instance P.Matchable Lets 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.
+ conditional _cs bs a b =
+ letsNode (Lets (mapM_ unLets bs >> unLets a >> unLets b))
+instance P.Foldable Lets
+instance P.Charable Lets
+instance P.Lookable Lets
+
+-- ** Type 'LetsState'
+data LetsState = LetsState
+ { lets_preds :: HashMap ParserName Int
+ , lets_recs :: HashSet ParserName
+ } deriving (Show)
+
+emptyLetsState :: LetsState
+emptyLetsState = LetsState
+ { lets_preds = HM.empty
+ , lets_recs = HS.empty
+ }
+
+
+
+{-
+type Binding o a x = Fix4 (Instr o) '[] One x a
+data LetBinding o a x = forall rs. LetBinding (Binding o a x) (Regs rs)
+deriving instance Show (LetBinding o a x)
+
+makeLetBinding :: Binding o a x -> Set IΣVar -> LetBinding o a x
+makeLetBinding m rs = LetBinding m (unsafeMakeRegs rs)
+
+data Regs (rs :: [Type]) where
+ NoRegs :: Regs '[]
+ FreeReg :: ΣVar r -> Regs rs -> Regs (r : rs)
+deriving instance Show (Regs rs)
+
+unsafeMakeRegs :: Set IΣVar -> Regs rs
+unsafeMakeRegs = foldr (\σ rs -> unsafeCoerce (FreeReg (ΣVar σ) rs)) (unsafeCoerce NoRegs)
+
+compile :: forall compiled a. Parser a -> (forall x. Maybe (MVar x) -> Fix Combinator x -> Set IΣVar -> IMVar -> IΣVar -> compiled x) -> (compiled a, DMap MVar compiled)
+compile (Parser p) codeGen = trace ("COMPILING NEW PARSER WITH " ++ show (DMap.size μs') ++ " LET BINDINGS") $ (codeGen' Nothing p', DMap.mapWithKey (codeGen' . Just) μs')
+ where
+ (p', μs, maxV) = preprocess p
+ (μs', frs, maxΣ) = dependencyAnalysis p' μs
+
+ freeRegs :: Maybe (MVar x) -> Set IΣVar
+ freeRegs = maybe Set.empty (\(MVar v) -> frs Map.! v)
+
+ codeGen' :: Maybe (MVar x) -> Fix Combinator x -> compiled x
+ codeGen' letBound p = codeGen letBound (analyse (emptyFlags {letBound = isJust letBound}) p) (freeRegs letBound) (maxV + 1) (maxΣ + 1)
+
+preprocess :: Fix (Combinator :+: ScopeRegister) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
+preprocess p =
+ let q = tagParser p
+ (lets, recs) = findLets q
+ (p', μs, maxV) = letInsertion lets recs q
+ in (p', μs, maxV)
+
+data Tag t f (k :: Type -> Type) a = Tag {tag :: t, tagged :: f k a}
+
+tagParser :: Fix (Combinator :+: ScopeRegister) a -> Fix (Tag ParserName Combinator) a
+tagParser p = cata' tagAlg p
+ where
+ tagAlg p = In . Tag (makeParserName p) . (id \/ descope)
+ descope (ScopeRegister p f) = freshReg regMaker (\(reg@(Reg σ)) -> MakeRegister σ p (f reg))
+ regMaker :: IORef IΣVar
+ regMaker = newRegMaker p
+
+
+newtype LetInserter a =
+ LetInserter {
+ doLetInserter :: HFreshT IMVar
+ (State ( HashMap ParserName IMVar
+ , DMap MVar (Fix Combinator)))
+ (Fix Combinator a)
+ }
+letInsertion :: HashSet ParserName -> HashSet ParserName -> Fix (Tag ParserName Combinator) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
+letInsertion lets recs p = (p', μs, μMax)
+ where
+ m = cata alg p
+ ((p', μMax), (_, μs)) = runState (runFreshT (doLetInserter m) 0) (HashMap.empty, DMap.empty)
+ alg :: Tag ParserName Combinator LetInserter a -> LetInserter a
+ alg p = LetInserter $ do
+ let name = tag p
+ let q = tagged p
+ (vs, μs) <- get
+ let bound = HashSet.member name lets
+ let recu = HashSet.member name recs
+ if bound || recu then case HashMap.lookup name vs of
+ Just v -> let μ = MVar v in return $! optimise (Let recu μ (μs DMap.! μ))
+ Nothing -> mdo
+ v <- newVar
+ let μ = MVar v
+ put (HashMap.insert name v vs, DMap.insert μ q' μs)
+ q' <- doLetInserter (postprocess q)
+ return $! optimise (Let recu μ q')
+ else do doLetInserter (postprocess q)
+
+postprocess :: Combinator LetInserter a -> LetInserter a
+postprocess = LetInserter . fmap optimise . traverseCombinator doLetInserter
+
+getBefore :: MonadState LetsState m => m (HashSet ParserName)
+getBefore = gets before
+
+
+
+
+
+
+
+
+makeParserName :: Fix (Combinator :+: ScopeRegister) a -> ParserName
+-- Force evaluation of p to ensure that the stableName is correct first time
+makeParserName !p = unsafePerformIO (fmap (\(StableName name) -> ParserName name) (makeStableName p))
+
+-- The argument here stops GHC from floating it out, it should be provided something from the scope
+{-# NOINLINE newRegMaker #-}
+newRegMaker :: a -> IORef IΣVar
+newRegMaker x = x `seq` unsafePerformIO (newIORef 0)
+
+{-# NOINLINE freshReg #-}
+freshReg :: IORef IΣVar -> (forall r. Reg r a -> x) -> x
+freshReg maker scope = scope $ unsafePerformIO $ do
+ x <- readIORef maker
+ writeIORef maker (x + 1)
+ return $! Reg (ΣVar x)
+
+instance IFunctor f => IFunctor (Tag t f) where
+ imap f (Tag t k) = Tag t (imap f k)
+
+instance Eq ParserName where
+ (ParserName n) == (ParserName m) = eqStableName (StableName n) (StableName m)
+instance Hashable ParserName where
+ hash (ParserName n) = hashStableName (StableName n)
+ hashWithSalt salt (ParserName n) = hashWithSalt salt (StableName n)
+
+-- There is great evil in this world, and I'm probably responsible for half of it
+instance Show ParserName where showsPrec _ (ParserName n) = showHex (I# (unsafeCoerce# n))
+-}
import Data.Char (Char)
import Data.Either (Either(..), either)
import Data.Eq (Eq(..))
-import Data.Maybe (Maybe(..))
-import Data.Typeable
-import Prelude (undefined)
+-- import Data.Maybe (Maybe(..))
+-- import Data.Typeable
+-- import Prelude (undefined)
import qualified Data.Function as Function
import qualified Prelude as Pre
import Symantic.Base.Univariant
import Symantic.Parser.Grammar.Combinators
-import Symantic.Parser.Staging hiding (Runtimeable(..), OptRuntime(..))
-import qualified Symantic.Parser.Staging as S
-import qualified Language.Haskell.TH.Syntax as TH
+import Symantic.Parser.Staging hiding (Haskell(..))
+import qualified Symantic.Parser.Staging as Hask
+-- import qualified Language.Haskell.TH.Syntax as TH
--- * Type 'OptGram'
-data OptGram repr a where
- Pure :: S.OptRuntime S.Runtime a -> OptGram repr a
- Satisfy :: S.Runtime (Char -> Bool) -> OptGram repr Char
- Item :: OptGram repr Char
- Try :: OptGram repr a -> OptGram repr a
- Look :: OptGram repr a -> OptGram repr a
- NegLook :: OptGram repr a -> OptGram repr ()
- (:<*>) :: OptGram repr (a -> b) -> OptGram repr a -> OptGram repr b
- (:<|>) :: OptGram repr a -> OptGram repr a -> OptGram repr a
- Empty :: OptGram repr a
- Branch :: OptGram repr (Either a b) -> OptGram repr (a -> c) -> OptGram repr (b -> c) -> OptGram repr c
- Match :: Eq a => [S.Runtime (a -> Bool)] -> [OptGram repr b] -> OptGram repr a -> OptGram repr b -> OptGram repr b
- ChainPre :: OptGram repr (a -> a) -> OptGram repr a -> OptGram repr a
- ChainPost :: OptGram repr a -> OptGram repr (a -> a) -> OptGram repr a
+-- * Type 'Comb'
+data Comb repr a where
+ Pure :: Hask.Haskell Hask.Runtime a -> Comb repr a
+ Satisfy :: Hask.Runtime (Char -> Bool) -> Comb repr Char
+ Item :: Comb repr Char
+ Try :: Comb repr a -> Comb repr a
+ Look :: Comb repr a -> Comb repr a
+ NegLook :: Comb repr a -> Comb repr ()
+ (:<*>) :: Comb repr (a -> b) -> Comb repr a -> Comb repr b
+ (:<|>) :: 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.Runtime (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
-pattern (:<$>) :: S.OptRuntime S.Runtime (a -> b) -> OptGram repr a -> OptGram repr b
-pattern (:$>) :: OptGram repr a -> S.OptRuntime S.Runtime b -> OptGram repr b
-pattern (:<$) :: S.OptRuntime S.Runtime a -> OptGram repr b -> OptGram repr a
-pattern (:*>) :: OptGram repr a -> OptGram repr b -> OptGram repr b
-pattern (:<*) :: OptGram repr a -> OptGram repr b -> OptGram repr a
+pattern (:<$>) :: Hask.Haskell Hask.Runtime (a -> b) -> Comb repr a -> Comb repr b
+pattern (:$>) :: Comb repr a -> Hask.Haskell Hask.Runtime b -> Comb repr b
+pattern (:<$) :: Hask.Haskell Hask.Runtime 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 = S.Const :<$> x :<*> p
-pattern p :*> x = S.Id :<$ p :<*> x
+pattern x :<* p = Hask.Const :<$> x :<*> p
+pattern p :*> x = Hask.Id :<$ p :<*> x
infixl 3 :<|>
infixl 4 :<*>, :<*, :*>
infixl 4 :<$>, :<$, :$>
-instance Applicable (OptGram Runtime) where
- pure = Pure Function.. S.OptRuntime
+instance Applicable (Comb Runtime) where
+ pure = Pure Function.. Hask.Haskell
(<*>) = (:<*>)
-instance Alternable (OptGram repr) where
+instance Alternable (Comb repr) where
(<|>) = (:<|>)
empty = Empty
try = Try
-instance Selectable (OptGram repr) where
+instance Selectable (Comb repr) where
branch = Branch
-instance Matchable (OptGram repr) where
+instance Matchable (Comb repr) where
conditional = Match
-instance Foldable (OptGram repr) where
+instance Foldable (Comb repr) where
chainPre = ChainPre
chainPost = ChainPost
-instance Charable (OptGram repr) where
+instance Charable (Comb repr) where
satisfy = Satisfy
-instance Lookable (OptGram repr) where
+instance Lookable (Comb repr) where
look = Look
negLook = NegLook
-type instance Unlift (OptGram repr) = repr
+type instance Unlift (Comb repr) = repr
instance
( Applicable repr
, Alternable repr
, Charable repr
, Lookable repr
, Matchable repr
- ) => Unliftable (OptGram repr) where
+ ) => Unliftable (Comb repr) where
unlift = \case
Pure a -> pure (unlift a)
Satisfy p -> satisfy p
Empty -> empty
Branch lr l r -> branch (unlift lr) (unlift l) (unlift r)
Match cs bs a b -> conditional cs (unlift Pre.<$> bs) (unlift a) (unlift b)
+ ChainPre x y -> chainPre (unlift x) (unlift y)
+ ChainPost x y -> chainPost (unlift x) (unlift y)
-optGram ::
- OptGram repr a -> OptGram repr a
-optGram = \case
+optComb ::
+ Comb repr a -> Comb repr a
+optComb = \case
-- Applicable Right Absorption Law
Empty :<*> _ -> Empty
Empty :*> _ -> Empty
Empty :<* _ -> Empty
-- Applicable Failure Weakening Law
- u :<*> Empty -> optGram (u :*> Empty)
- u :<* Empty -> optGram (u :*> Empty)
+ u :<*> Empty -> optComb (u :*> Empty)
+ u :<* Empty -> optComb (u :*> Empty)
-- Branch Absorption Law
Branch Empty _ _ -> empty
-- Branch Weakening Law
- Branch b Empty Empty -> optGram (b :*> Empty)
+ Branch b Empty Empty -> optComb (b :*> Empty)
-- Applicable Identity Law
- S.Id :<$> x -> x
+ Hask.Id :<$> x -> x
-- Flip const optimisation
- S.Flip S.:@ S.Const :<$> u -> optGram (u :*> Pure S.Id)
+ Hask.Flip Hask.:@ Hask.Const :<$> u -> optComb (u :*> Pure Hask.Id)
-- Homomorphism Law
- f :<$> Pure x -> Pure (f S.:@ x)
+ f :<$> Pure x -> Pure (f Hask.:@ x)
-- Functor Composition Law
-- (a shortcut that could also have been be caught
-- by the Composition Law and Homomorphism law)
- f :<$> (g :<$> p) -> optGram ((S.:.) S.:@ f S.:@ g :<$> p)
+ f :<$> (g :<$> p) -> optComb ((Hask.:.) Hask.:@ f Hask.:@ g :<$> p)
-- Composition Law
- u :<*> (v :<*> w) -> optGram (optGram (optGram ((S.:.) :<$> u) :<*> v) :<*> w)
+ u :<*> (v :<*> w) -> optComb (optComb (optComb ((Hask.:.) :<$> u) :<*> v) :<*> w)
-- Definition of *>
- S.Flip S.:@ S.Const :<$> p :<*> q -> p :*> q
+ Hask.Flip Hask.:@ Hask.Const :<$> p :<*> q -> p :*> q
-- Definition of <*
- S.Const :<$> p :<*> q -> p :<* q
+ Hask.Const :<$> p :<*> q -> p :<* q
-- Reassociation Law 1
- (u :*> v) :<*> w -> optGram (u :*> (optGram (v :<*> w)))
+ (u :*> v) :<*> w -> optComb (u :*> optComb (v :<*> w))
-- Interchange Law
- u :<*> Pure x -> optGram (S.Flip S.:@ (S.:$) S.:@ x :<$> u)
+ u :<*> Pure x -> optComb (Hask.Flip Hask.:@ (Hask.:$) Hask.:@ x :<$> u)
-- Right Absorption Law
(_ :<$> p) :*> q -> p :*> q
-- Left Absorption Law
p :<* (_ :<$> q) -> p :<* q
-- Reassociation Law 2
- u :<*> (v :<* w) -> optGram (optGram (u :<*> v) :<* w)
+ u :<*> (v :<* w) -> optComb (optComb (u :<*> v) :<* w)
-- Reassociation Law 3
- u :<*> (v :$> x) -> optGram (optGram (u :<*> Pure x) :<* v)
+ u :<*> (v :$> x) -> optComb (optComb (u :<*> Pure x) :<* v)
-- Left Catch Law
p@Pure{} :<|> _ -> p
-- Right Neutral Law
u :<|> Empty -> u
-- Associativity Law
- (u :<|> v) :<|> w -> u :<|> optGram (v :<|> w)
+ (u :<|> v) :<|> w -> u :<|> optComb (v :<|> w)
-- Identity law
Pure _ :*> u -> u
-- Identity law
(u :$> _) :*> v -> u :*> v
-- Associativity Law
- u :*> (v :*> w) -> optGram (optGram (u :*> v) :*> w)
+ u :*> (v :*> w) -> optComb (optComb (u :*> v) :*> w)
-- Identity law
u :<* Pure _ -> u
-- Identity law
- u :<* (v :$> _) -> optGram (u :<* v)
+ u :<* (v :$> _) -> optComb (u :<* v)
-- Commutativity Law
- x :<$ u -> optGram (u :$> x)
+ x :<$ u -> optComb (u :$> x)
-- Associativity Law
- (u :<* v) :<* w -> optGram (u :<* optGram (v :<* w))
+ (u :<* v) :<* w -> optComb (u :<* optComb (v :<* w))
-- Pure lookahead
Look p@Pure{} -> p
NegLook Pure{} -> Empty
-- Dead negative-lookahead
- NegLook Empty -> Pure S.unit
+ NegLook Empty -> Pure Hask.unit
-- Double Negation Law
- NegLook (NegLook p) -> optGram (Look (Try p) :*> Pure S.unit)
+ NegLook (NegLook p) -> optComb (Look (Try p) :*> Pure Hask.unit)
-- Zero Consumption Law
- NegLook (Try p) -> optGram (NegLook p)
+ NegLook (Try p) -> optComb (NegLook p)
-- Idempotence Law
Look (Look p) -> Look p
-- Right Identity Law
- NegLook (Look p) -> optGram (NegLook p)
+ NegLook (Look p) -> optComb (NegLook p)
-- Left Identity Law
Look (NegLook p) -> NegLook p
-- Transparency Law
- NegLook (Try p :<|> q) -> optGram (optGram (NegLook p) :*> optGram (NegLook q))
+ NegLook (Try p :<|> q) -> optComb (optComb (NegLook p) :*> optComb (NegLook q))
-- Distributivity Law
- Look p :<|> Look q -> optGram (Look (optGram (Try p :<|> q)))
+ Look p :<|> Look q -> optComb (Look (optComb (Try p :<|> q)))
-- Interchange Law
- Look (p :$> x) -> optGram (optGram (Look p) :$> x)
+ Look (p :$> x) -> optComb (optComb (Look p) :$> x)
-- Interchange law
- Look (f :<$> p) -> optGram (f :<$> optGram (Look p))
+ Look (f :<$> p) -> optComb (f :<$> optComb (Look p))
-- Absorption Law
- p :<*> NegLook q -> optGram (optGram (p :<*> Pure S.unit) :<* NegLook q)
+ p :<*> NegLook q -> optComb (optComb (p :<*> Pure Hask.unit) :<* NegLook q)
-- Idempotence Law
- NegLook (p :$> _) -> optGram (NegLook p)
+ NegLook (p :$> _) -> optComb (NegLook p)
-- Idempotence Law
- NegLook (_ :<$> p) -> optGram (NegLook p)
+ NegLook (_ :<$> p) -> optComb (NegLook p)
-- Interchange Law
- Try (p :$> x) -> optGram (optGram (Try p) :$> x)
+ Try (p :$> x) -> optComb (optComb (Try p) :$> x)
-- Interchange law
- Try (f :<$> p) -> optGram (f :<$> optGram (Try p))
+ Try (f :<$> p) -> optComb (f :<$> optComb (Try p))
-- pure Left/Right laws
Branch (Pure (unlift -> lr)) l r ->
case getEval lr of
- Left e -> optGram (l :<*> Pure (S.OptRuntime (Runtime (Eval e) c)))
+ Left e -> optComb (l :<*> Pure (Hask.Haskell (Runtime (Eval e) c)))
where c = Code [|| case $$(getCode lr) of Left x -> x ||]
- Right e -> optGram (r :<*> Pure (S.OptRuntime (Runtime (Eval e) c)))
+ Right e -> optComb (r :<*> Pure (Hask.Haskell (Runtime (Eval e) c)))
where c = Code [|| case $$(getCode lr) of Right x -> x ||]
-- Generalised Identity law
Branch b (Pure (unlift -> l)) (Pure (unlift -> r)) ->
- optGram (S.OptRuntime (Runtime e c) :<$> b)
+ optComb (Hask.Haskell (Runtime e c) :<$> b)
where
e = Eval (either (getEval l) (getEval r))
c = Code [|| either $$(getCode l) $$(getCode r) ||]
-- Interchange law
Branch (x :*> y) p q ->
- optGram (x :*> optGram (Branch y p q))
+ optComb (x :*> optComb (Branch y p q))
-- Negated Branch law
Branch b l Empty ->
- Branch (Pure (S.OptRuntime (Runtime e c)) :<*> b) Empty l
+ Branch (Pure (Hask.Haskell (Runtime e c)) :<*> b) Empty l
where
e = Eval (either Right Left)
c = Code [||either Right Left||]
-- Branch Fusion law
Branch (Branch b Empty (Pure (unlift -> lr))) Empty br ->
- optGram (Branch (optGram (Pure (S.OptRuntime (Runtime (Eval e) c)) :<*> b)) Empty br)
+ optComb (Branch (optComb (Pure (Hask.Haskell (Runtime (Eval e) c)) :<*> b)) Empty br)
where
e Left{} = Left ()
e (Right r) = case getEval lr r of
Left _ -> Left ()
Right rr -> Right rr ||]
-- Distributivity Law
- f :<$> Branch b l r -> optGram (Branch b (optGram ((S..@) (S..) f :<$> l))
- (optGram ((S..@) (S..) f :<$> r)))
+ f :<$> Branch b l r -> optComb (Branch b (optComb ((Hask..@) (Hask..) f :<$> l))
+ (optComb ((Hask..@) (Hask..) f :<$> r)))
x -> x
import Data.Bool (Bool)
import Data.Char (Char)
import Data.Eq (Eq)
-import Data.Functor.Identity (Identity(..))
import Language.Haskell.TH (TExpQ)
import qualified Data.Eq as Eq
import qualified Data.Function as Function
unlift = Function.id
{-# INLINE unlift #-}
--- * Class 'Runtimeable'
--- | Final encoding of some Runtimeable functions
+-- * Class 'Haskellable'
+-- | Final encoding of some Haskellable functions
-- useful for some optimizations in 'optGram'.
-class Runtimeable (app :: * -> *) where
+class Haskellable (app :: * -> *) where
runtime :: Unlift app a -> app a
- (.) :: app ((b->c) -> (a->b) -> a -> c)
- ($) :: app ((a->b) -> a -> b)
- (.@) :: app (a->b) -> app a -> app b
- bool :: Bool -> app Bool
- char :: Char -> app Char
- cons :: app (a -> [a] -> [a])
+ (.) :: app ((b->c) -> (a->b) -> a -> c)
+ ($) :: app ((a->b) -> a -> b)
+ (.@) :: app (a->b) -> app a -> app b
+ bool :: Bool -> app Bool
+ char :: Char -> app Char
+ cons :: app (a -> [a] -> [a])
const :: app (a -> b -> a)
- eq :: Eq a => app a -> app (a -> Bool)
- flip :: app ((a -> b -> c) -> b -> a -> c)
- id :: app (a->a)
- nil :: app [a]
- unit :: app ()
-instance Runtimeable Identity
+ eq :: Eq a => app a -> app (a -> Bool)
+ flip :: app ((a -> b -> c) -> b -> a -> c)
+ id :: app (a->a)
+ nil :: app [a]
+ unit :: app ()
+-- instance Haskellable Identity
--- ** Type 'Runtimeable'
--- | Initial encoding of 'Runtimeable'
-data OptRuntime (app:: * -> *) a where
- OptRuntime :: app a -> OptRuntime app a
- (:.) :: OptRuntime app ((b->c) -> (a->b) -> a -> c)
- (:$) :: OptRuntime app ((a->b) -> a -> b)
- (:@) :: OptRuntime app (a->b) -> OptRuntime app a -> OptRuntime app b
- Const :: OptRuntime app (a -> b -> a)
- Flip :: OptRuntime app ((a -> b -> c) -> b -> a -> c)
- Id :: OptRuntime app (a->a)
-type instance Unlift (OptRuntime app) = app
-instance (Liftable app, Unliftable app, Runtimeable app) => Liftable (OptRuntime app) where
- lift = OptRuntime
-instance (Unliftable app, Runtimeable app) => Unliftable (OptRuntime app) where
+-- ** Type 'Haskellable'
+-- | Initial encoding of 'Haskellable'
+data Haskell (app:: * -> *) a where
+ Haskell :: app a -> Haskell app a
+ (:.) :: Haskell app ((b->c) -> (a->b) -> a -> c)
+ (:$) :: Haskell app ((a->b) -> a -> b)
+ (:@) :: Haskell app (a->b) -> Haskell app a -> Haskell app b
+ Const :: Haskell app (a -> b -> a)
+ Flip :: Haskell app ((a -> b -> c) -> b -> a -> c)
+ Id :: Haskell app (a->a)
+type instance Unlift (Haskell app) = app
+instance (Liftable app, Unliftable app, Haskellable app) => Liftable (Haskell app) where
+ lift = Haskell
+instance (Unliftable app, Haskellable app) => Unliftable (Haskell app) where
unlift = \case
- OptRuntime x -> runtime (unlift x)
- (:.) -> (.)
- (:$) -> ($)
+ Haskell x -> runtime (unlift x)
+ (:.) -> (.)
+ (:$) -> ($)
(:@) f x -> (.@) (unlift f) (unlift x)
- Const -> const
- Flip -> flip
- Id -> id
+ Const -> const
+ Flip -> flip
+ Id -> id
infixr 0 $, :$
infixr 9 ., :.
infixl 9 .@, :@
-instance Runtimeable (OptRuntime app) where
- runtime = OptRuntime
+instance Haskellable (Haskell app) where
+ runtime = Haskell
(.) = (:.)
($) = (:$)
(.@) = (:@)
const = Const
flip = Flip
id = Id
-instance Runtimeable Runtime where
+instance Haskellable Runtime where
runtime = Function.id
(.) = Runtime (.) (.)
($) = Runtime ($) ($)
id = Runtime id id
nil = Runtime nil nil
unit = Runtime unit unit
-instance Runtimeable Eval where
+instance Haskellable Eval where
runtime = lift
(.) = Eval (Function..)
($) = Eval (Function.$)
- (.@) f x = Eval ((unEval f) (unEval x))
+ (.@) f x = Eval (unEval f (unEval x))
bool = Eval
char = Eval
cons = Eval (:)
id = Eval Function.id
nil = Eval []
unit = Eval ()
-instance Runtimeable Code where
+instance Haskellable Code where
runtime = lift
(.) = Code [|| \f g x -> f (g x) ||]
($) = Code [|| \f x -> f x ||]
Symantic.Parser.Grammar.Combinators
Symantic.Parser.Grammar.Observations
Symantic.Parser.Grammar.Optimizations
+ Symantic.Parser.Automaton
+ Symantic.Parser.Automaton.Instructions
Symantic.Parser.Staging
Symantic.Base.Univariant
other-modules:
array,
bytestring,
containers,
- dependent-map >= 0.4.0.0,
- dependent-sum >= 0.7.1.0,
+ -- dependent-map >= 0.4.0.0,
+ -- dependent-sum >= 0.7.1.0,
+ dependent-map,
+ dependent-sum,
ghc-prim,
hashable,
- template-haskell >= 2.16,
+ template-haskell >= 2.15,
+ -- template-haskell >= 2.16,
text,
transformers,
unordered-containers
sourcephile / git / haskell / symantic-parser.git / commitdiff