override RTS_OPTIONS += -L100
override TEST_OPTIONS += --color always --size-cutoff 1000000 $(addprefix -p ,$t)
-override GHC_PROF_OPTIONS += -fprof-auto -fprof-auto-calls
+override GHC_PROF_OPTIONS += -eventlog -fprof-auto -fprof-auto-calls
override BENCHMARK_OPTIONS += --output benchmarks/html/$(version).html --match glob $b
override REPL_OPTIONS += -ignore-dot-ghci
### Main differences with respect to `ParsleyHaskell`
-- Extensible primitive grammar combinators, including their underlying optimization passes, by leveraging reciprocal injections between a tagless-final encoding of syntaxes (aka. type-classes) and a corresponding tagged-initial encoding to pattern-match syntaxes (aka. data-instances). This is a final approach to recursion patterns, whereas [recursion-schemes](http://hackage.haskell.org/package/recursion-schemes) is an initial one. Here `DefaultSignatures` are supplied to succinctly derive new semantics (aka. type-class-instances) using automatic `trans`formations.
+- Primitive grammar combinators are extensible, including the optimization pass for which they are the current top-level combinator.
-- Error messages based upon the farthest input position reached (not yet implemented in `ParsleyHaskell`).
+- Error messages are based upon the farthest input position reached (not yet implemented in `ParsleyHaskell`) and a there is a preliminary support for error messages based upon [labeled failures](https://dl.acm.org/doi/10.1145/2851613.2851750).
-- Minimal input length checks ("horizon" checks) required for a successful parsing are factorized using a different static analysis than `ParsleyHaskell`'s "piggy bank" which I've not understood well. This analysis uses [polyfix](http://okmij.org/ftp/Computation/fixed-point-combinators.html#Poly-variadic) to see beyond calls to subroutines.
+- Minimal input length checks ("horizon" checks) required for a successful parsing are statically computed using a [polyfix](http://okmij.org/ftp/Computation/fixed-point-combinators.html#Poly-variadic) to see beyond calls to subroutines, which is not (yet) possible in `ParsleyHaskell`.
-- No dependency upon GHC plugins: `lift-plugin`, `idioms-plugin` or `parsley-garnish`. Because those are plugins hence introduce a bit of complexity in the build processes using this parser, but most importantly they are experimental and mostly cosmetics, since they only enable a cleaner usage of the parsing combinators: by quoting an Haskell expression as itself and its `TemplateHaskell` equivalent. I do not understand them that much and do not feel confortable to maintain them come the day that their authors abandon them.
+- No dependency upon GHC plugins: `lift-plugin`, `idioms-plugin` or `parsley-garnish` for users. Those provide convenient syntaxic-sugar (by quoting an Haskell expression as itself and its `TemplateHaskell` equivalent) for writing grammar productions, but are experimental, but I do not understand them that much and do not feel confortable to maintain them in case their authors abandon them.
-- No dependency upon `dependent-map` by keeping observed sharing inside `def` and `ref` combinators, instead of passing by a `DMap`. And also when introducing the join-points optimization, where fresh `TemplateHaskell` names are also directly used instead of passing by a `DMap`.
+- No dependency upon `dependent-map` by keeping observed sharing in `def` and `ref` combinators, instead of passing by a `DMap`. And also when introducing the join-points optimization, where fresh `TemplateHaskell` names are also directly used instead of passing by a `DMap`.
-- No support (yet?) for general purpose registers in the `Machine` producing the `TemplateHaskell` splices.
+- No support (yet?) for general purpose registers in the `Machine` producing the `TemplateHaskell` splices. Hence `symantic-parser` generates parser much slower than `ParsleyHaskell`, comparable to `attoparsec` in the Brainfuck benchmark.
- License is `AGPL-3-or-later` not `BSD-3-Clause`.
-- Some generated `TemplateHaskell` is followed by golden tests.
+- Testing grammars have their generated machines and `TemplateHaskell` splices followed by golden tests.
### Main goals
- For me to better understand [ParsleyHaskell](https://github.com/j-mie6/ParsleyHaskell), and find a manageable balance between simplicity of the codebase and features of the parser. And by doing so, challenging and showcasing symantic techniques.
- To support the parsing of tree-like data structures instead of only string-like data structures. Eg. to validate XML using RelaxNG in [symantic-xml](https://hackage.haskell.org/package/symantic-xml) or to perform routing of HTTP requests in [symantic-http-server](http://hackage.haskell.org/package/symantic-http-server). This is currently done in those packages using `megaparsec`, but `megaparsec` is not conceived for such input, and is less principled when it comes to optimizing, like merging alternatives.
+
+### Implementation techniques
+
+#### Typed Tagless-Final
+The syntax of grammars are term-level combinators defined in type-classes,
+and their semantics are data-types having instances of those type-classes.
+And the same technique is applied for machine instructions and grammar productions.
+
+For automatic deriving, `DefaultSignatures` are supplied using automatic `trans`formations, see `Symantic.Typed.Trans`.
+
+For pattern-matching, data-families indexed by the syntaxic type-class are supplied,
+see `Symantic.Typed.Data`.
{ pkgs ? import <nixpkgs> {}
, ghc ? "ghc901"
, withHoogle ? false
+, inputs
}:
let
haskellPackages =
hs-speedscope = doJailbreak (unmarkBroken hsuper.hs-speedscope);
eventlog2html = doJailbreak (unmarkBroken hsuper.eventlog2html);
trie-simple = doJailbreak (unmarkBroken hsuper.trie-simple);
- symantic-parser = buildFromSdist (hself.callCabal2nix "symantic-parser" ./. {});
+ symantic-base = buildFromSdist (hself.callCabal2nix "symantic-base" inputs.symantic-base {});
+ symantic-parser = doBenchmark (buildFromSdist (hself.callCabal2nix "symantic-parser" ./. {}));
+ /*
hlint = hsuper.hlint_3_3_1.overrideScope (self: super: {
ghc-lib-parser = overrideCabal self.ghc-lib-parser_9_0_1_20210324 {
doHaddock = false;
};
ghc-lib-parser-ex = self.ghc-lib-parser-ex_9_0_0_4;
});
+ */
}
);
in hs.symantic-parser // {
hs.eventlog2html
hs.ghc-events
hs.ghcid
- hs.hlint
+ #hs.hlint
hs.hs-speedscope
hs.ormolu
hs.profiteur
"type": "github"
}
},
+ "flake-utils_2": {
+ "locked": {
+ "lastModified": 1623875721,
+ "narHash": "sha256-A8BU7bjS5GirpAUv4QA+QnJ4CceLHkcXdRp4xITDB0s=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "f7e004a55b120c02ecb6219596820fcd32ca8772",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
"nixpkgs": {
"locked": {
"narHash": "sha256-3C35/g5bJ3KH67fOpxTkqDpfJ1CHYrO2bbl+fPgqfMQ=",
"root": {
"inputs": {
"flake-utils": "flake-utils",
- "nixpkgs": "nixpkgs"
+ "nixpkgs": "nixpkgs",
+ "symantic-base": "symantic-base"
+ }
+ },
+ "symantic-base": {
+ "inputs": {
+ "flake-utils": "flake-utils_2",
+ "nixpkgs": [
+ "nixpkgs"
+ ]
+ },
+ "locked": {
+ "lastModified": 1626033315,
+ "narHash": "sha256-vHRFhc9Bg2cxrAR9R1TSXn2f6ZwzOIMRD+0n3cXzl54=",
+ "ref": "master",
+ "rev": "29078a0e7fbe8df3204bcf86dd902a301072574f",
+ "revCount": 14,
+ "type": "git",
+ "url": "git://git.sourcephile.fr/haskell/symantic-base"
+ },
+ "original": {
+ "type": "git",
+ "url": "git://git.sourcephile.fr/haskell/symantic-base"
}
}
},
{
inputs.nixpkgs.url = "flake:nixpkgs";
+#inputs.nixpkgs.url = "github:NixOS/nixpkgs";
inputs.flake-utils.url = "github:numtide/flake-utils";
+inputs.symantic-base.url = "git://git.sourcephile.fr/haskell/symantic-base";
+inputs.symantic-base.inputs.nixpkgs.follows = "nixpkgs";
outputs = inputs:
inputs.flake-utils.lib.eachDefaultSystem (system: let
pkgs = inputs.nixpkgs.legacyPackages.${system};
in {
- defaultPackage = import ./default.nix { inherit pkgs; };
- devShell = (import ./default.nix { inherit pkgs; }).shell;
+ defaultPackage = import ./default.nix { inherit inputs pkgs; };
+ devShell = (import ./default.nix { inherit inputs pkgs; }).shell;
}
);
}
module Symantic.Parser.Grammar
( module Symantic.Parser.Grammar
, module Symantic.Parser.Grammar.Combinators
- , module Symantic.Parser.Grammar.Fixity
, module Symantic.Parser.Grammar.Optimize
, module Symantic.Parser.Grammar.ObserveSharing
, module Symantic.Parser.Grammar.Production
, Letsable(..)
) where
import Symantic.Parser.Grammar.Combinators
-import Symantic.Parser.Grammar.Fixity
import Symantic.Parser.Grammar.ObserveSharing
import Symantic.Parser.Grammar.Optimize
import Symantic.Parser.Grammar.Production
-- The default type signature of type class methods are changed
--- to introduce a 'Liftable' constraint and the same type class but on the 'Unlifted' repr,
+-- to introduce a 'LiftDerived'* constraint and the same type class but on the 'Derived' repr,
-- this setup avoids to define the method with boilerplate code when its default
--- definition with lift* and 'trans' does what is expected by an instance
+-- definition with 'liftDerived'* and 'derive' does what is expected by an instance
-- of the type class. This is almost as explained in:
-- https://ro-che.info/articles/2016-02-03-finally-tagless-boilerplate
{-# LANGUAGE DefaultSignatures #-}
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-import qualified Symantic.Typed.Trans as Sym
+import Symantic.Typed.Derive
import qualified Symantic.Typed.Lang as Prod
import Symantic.Parser.Grammar.Production
-- Generally used on the first alternative: @('try' rl '<|>' rr)@.
try :: repr a -> repr a
default alt ::
- Sym.Liftable2 repr => CombAlternable (Sym.Unlifted repr) =>
+ FromDerived2 CombAlternable repr =>
Exception -> repr a -> repr a -> repr a
default throw ::
- Sym.Liftable repr => CombAlternable (Sym.Unlifted repr) =>
+ FromDerived CombAlternable repr =>
ExceptionLabel -> repr a
default try ::
- Sym.Liftable1 repr => CombAlternable (Sym.Unlifted repr) =>
+ FromDerived1 CombAlternable repr =>
repr a -> repr a
- alt = Sym.lift2 . alt
- throw = Sym.lift . throw
- try = Sym.lift1 try
+ alt = liftDerived2 . alt
+ throw = liftDerived . throw
+ try = liftDerived1 try
failure :: SomeFailure -> repr a
default failure ::
- Sym.Liftable repr => CombAlternable (Sym.Unlifted repr) =>
+ FromDerived CombAlternable repr =>
SomeFailure -> repr a
- failure = Sym.lift . failure
+ failure = liftDerived . failure
-- | @(empty)@ parses nothing, always failing to return a value.
empty :: repr a
-- ** Type 'SomeFailure'
data SomeFailure =
forall comb.
- ({-Trans (Failure comb repr) repr,-}
- Eq (Failure comb)
+ ( Eq (Failure comb)
, Ord (Failure comb)
, Show (Failure comb)
, TH.Lift (Failure comb)
rnf (SomeFailure x) = rnf x
{-
-instance Trans (SomeFailure repr) repr where
- trans (SomeFailure x) = trans x
+instance Derivable (SomeFailure repr) where
+ derive (SomeFailure x) = derive x
-}
-- | @(unSomeFailure c :: 'Maybe' ('Failure' comb repr a))@
-- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
pure :: Production a -> repr a
default pure ::
- Sym.Liftable repr => CombApplicable (Sym.Unlifted repr) =>
+ FromDerived CombApplicable repr =>
Production a -> repr a
- pure = Sym.lift . pure
+ pure = liftDerived . pure
-- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
-- and returns the application of the function returned by @(ra2b)@
-- to the value returned by @(ra)@.
(<*>) :: repr (a -> b) -> repr a -> repr b
default (<*>) ::
- Sym.Liftable2 repr => CombApplicable (Sym.Unlifted repr) =>
+ FromDerived2 CombApplicable repr =>
repr (a -> b) -> repr a -> repr b
- (<*>) = Sym.lift2 (<*>)
+ (<*>) = liftDerived2 (<*>)
-- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@,
-- and returns like @(ra)@, discarding the return value of @(rb)@.
chainPost :: repr a -> repr (a -> a) -> repr a
{-
default chainPre ::
- Sym.Liftable2 repr => CombFoldable (Sym.Unlifted repr) =>
+ FromDerived2 CombFoldable repr =>
repr (a -> a) -> repr a -> repr a
default chainPost ::
- Sym.Liftable2 repr => CombFoldable (Sym.Unlifted repr) =>
+ FromDerived2 CombFoldable repr =>
repr a -> repr (a -> a) -> repr a
- chainPre = Sym.lift2 chainPre
- chainPost = Sym.lift2 chainPost
+ chainPre = liftDerived2 chainPre
+ chainPost = liftDerived2 chainPost
-}
default chainPre ::
CombApplicable repr =>
conditional ::
Eq a => repr a -> [Production (a -> Bool)] -> [repr b] -> repr b -> repr b
default conditional ::
- Sym.Unliftable repr => Sym.Liftable1 repr => CombMatchable (Sym.Unlifted repr) =>
+ FromDerived1 CombMatchable repr => Derivable repr =>
Eq a => repr a -> [Production (a -> Bool)] -> [repr b] -> repr b -> repr b
- conditional a ps bs = Sym.lift1 (conditional (Sym.unlift a) ps (Sym.unlift Functor.<$> bs))
+ conditional a ps bs = liftDerived1 (conditional (derive a) ps (derive Functor.<$> bs))
match :: Eq a => repr a -> [Production a] -> (Production a -> repr b) -> repr b -> repr b
match a as a2b = conditional a ((Prod.equal Prod..@) Functor.<$> as) (a2b Functor.<$> as)
Set SomeFailure ->
Production (tok -> Bool) -> repr tok
default satisfyOrFail ::
- Sym.Liftable repr => CombSatisfiable tok (Sym.Unlifted repr) =>
+ FromDerived (CombSatisfiable tok) repr =>
Set SomeFailure ->
Production (tok -> Bool) -> repr tok
- satisfyOrFail fs = Sym.lift . satisfyOrFail fs
+ satisfyOrFail fs = liftDerived . satisfyOrFail fs
data instance Failure (CombSatisfiable tok)
= FailureAny
class CombSelectable repr where
branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
default branch ::
- Sym.Liftable3 repr => CombSelectable (Sym.Unlifted repr) =>
+ FromDerived3 CombSelectable repr =>
repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
- branch = Sym.lift3 branch
+ branch = liftDerived3 branch
data instance Failure CombSelectable
-- * Class 'CombLookable'
class CombLookable repr where
look :: repr a -> repr a
negLook :: repr a -> repr ()
- default look :: Sym.Liftable1 repr => CombLookable (Sym.Unlifted repr) => repr a -> repr a
- default negLook :: Sym.Liftable1 repr => CombLookable (Sym.Unlifted repr) => repr a -> repr ()
- look = Sym.lift1 look
- negLook = Sym.lift1 negLook
+ default look ::
+ FromDerived1 CombLookable repr =>
+ repr a -> repr a
+ default negLook ::
+ FromDerived1 CombLookable repr =>
+ repr a -> repr ()
+ look = liftDerived1 look
+ negLook = liftDerived1 negLook
eof :: repr ()
- eof = Sym.lift eof
- default eof :: Sym.Liftable repr => CombLookable (Sym.Unlifted repr) => repr ()
+ eof = liftDerived eof
+ default eof ::
+ FromDerived CombLookable repr =>
+ repr ()
-- eof = negLook (satisfy @Char (Prod.const Prod..@ Prod.bool True))
-- (item @Char)
data instance Failure CombLookable
+++ /dev/null
-module Symantic.Parser.Grammar.Fixity where
-
-import Data.Bool
-import Data.Eq (Eq(..))
-import Data.Function ((.))
-import Data.Int (Int)
-import Data.Maybe (Maybe(..))
-import Data.Ord (Ord(..))
-import Data.Semigroup
-import Data.String (String, IsString(..))
-import Text.Show (Show(..))
-
--- * Type 'Fixity'
-data Fixity
- = Fixity1 Unifix
- | Fixity2 Infix
- deriving (Eq, Show)
-
--- ** Type 'Unifix'
-data Unifix
- = Prefix { unifix_precedence :: Precedence }
- | Postfix { unifix_precedence :: Precedence }
- deriving (Eq, Show)
-
--- ** Type 'Infix'
-data Infix
- = Infix
- { infix_associativity :: Maybe Associativity
- , infix_precedence :: Precedence
- } deriving (Eq, Show)
-
-infixL :: Precedence -> Infix
-infixL = Infix (Just AssocL)
-
-infixR :: Precedence -> Infix
-infixR = Infix (Just AssocR)
-
-infixB :: Side -> Precedence -> Infix
-infixB = Infix . Just . AssocB
-
-infixN :: Precedence -> Infix
-infixN = Infix Nothing
-
-infixN0 :: Infix
-infixN0 = infixN 0
-
-infixN5 :: Infix
-infixN5 = infixN 5
-
--- | Given 'Precedence' and 'Associativity' of its parent operator,
--- and the operand 'Side' it is in,
--- return whether an 'Infix' operator
--- needs to be enclosed by a 'Pair'.
-isPairNeeded :: (Infix, Side) -> Infix -> Bool
-isPairNeeded (po, lr) op =
- infix_precedence op < infix_precedence po
- || infix_precedence op == infix_precedence po
- && not associate
- where
- associate =
- case (lr, infix_associativity po) of
- (_, Just AssocB{}) -> True
- (SideL, Just AssocL) -> True
- (SideR, Just AssocR) -> True
- _ -> False
-
--- | If 'isPairNeeded' is 'True',
--- enclose the given 'IsString' by given 'Pair',
--- otherwise returns the same 'IsString'.
-pairIfNeeded ::
- Semigroup s => IsString s =>
- Pair -> (Infix, Side) -> Infix ->
- s -> s
-pairIfNeeded (o,c) po op s =
- if isPairNeeded po op
- then fromString o <> s <> fromString c
- else s
-
--- * Type 'Precedence'
-type Precedence = Int
-
--- ** Class 'PrecedenceOf'
-class PrecedenceOf a where
- precedence :: a -> Precedence
-instance PrecedenceOf Fixity where
- precedence (Fixity1 uni) = precedence uni
- precedence (Fixity2 inf) = precedence inf
-instance PrecedenceOf Unifix where
- precedence = unifix_precedence
-instance PrecedenceOf Infix where
- precedence = infix_precedence
-
--- * Type 'Associativity'
-data Associativity
- = AssocL -- ^ Associate to the left: @a ¹ b ² c == (a ¹ b) ² c@
- | AssocR -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@
- | AssocB Side -- ^ Associate to both sides, but to 'Side' when reading.
- deriving (Eq, Show)
-
--- ** Type 'Side'
-data Side
- = SideL -- ^ Left
- | SideR -- ^ Right
- deriving (Eq, Show)
-
--- ** Type 'Pair'
-type Pair = (String, String)
-pairAngle :: Pair
-pairBrace :: Pair
-pairBracket :: Pair
-pairParen :: Pair
-pairAngle = ("<",">")
-pairBrace = ("{","}")
-pairBracket = ("[","]")
-pairParen = ("(",")")
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.ObserveSharing
- ( module Symantic.Typed.Letable
+ ( module Symantic.Typed.ObserveSharing
, module Symantic.Parser.Grammar.ObserveSharing
) where
import qualified Control.Applicative as Functor
import Symantic.Parser.Grammar.Combinators
-import Symantic.Typed.Letable hiding (observeSharing)
-import qualified Symantic.Typed.Letable as Letable
+import Symantic.Typed.Derive
+import Symantic.Typed.ObserveSharing hiding (observeSharing)
+import qualified Symantic.Typed.ObserveSharing as ObserveSharing
import qualified Language.Haskell.TH.Syntax as TH
-import qualified Symantic.Typed.Trans as Sym
--- | Like 'Letable.observeSharing'
+-- | Like 'Observable.observeSharing'
-- but type-binding @(letName)@ to 'TH.Name'
-- to avoid the trouble to always set it.
observeSharing :: Letsable TH.Name repr => ObserveSharing TH.Name repr a -> repr a
observeSharing os = lets defs body
- where (body, defs) = Letable.observeSharing os
+ where (body, defs) = ObserveSharing.observeSharing os
-- | Needed by 'observeSharing'.
instance Hashable TH.Name where
( Letable TH.Name repr
, CombFoldable repr
{- TODO: the following constraints are for the current CombFoldable,
- - they will have to be removed when CombFoldable will have Sym.lift2 as defaults
+ - they will have to be removed when CombFoldable will have 'liftDerived2' as defaults
-}
, CombApplicable repr
, CombAlternable repr
instance CombApplicable repr => CombApplicable (FinalizeSharing TH.Name repr)
instance CombAlternable repr => CombAlternable (FinalizeSharing TH.Name repr)
instance CombFoldable repr => CombFoldable (FinalizeSharing TH.Name repr) where
- chainPre = Sym.lift2 chainPre
- chainPost = Sym.lift2 chainPost
+ chainPre = liftDerived2 chainPre
+ chainPost = liftDerived2 chainPost
instance CombLookable repr => CombLookable (FinalizeSharing TH.Name repr)
instance CombMatchable repr => CombMatchable (FinalizeSharing TH.Name repr) where
conditional a cs bs b = FinalizeSharing $
import Symantic.Parser.Grammar.Combinators
import Symantic.Parser.Grammar.Production
-import Symantic.Typed.Letable
-import Symantic.Typed.Trans
+import Symantic.Typed.Derive
+import Symantic.Typed.ObserveSharing
import qualified Symantic.Typed.Data as Prod
import qualified Symantic.Typed.Lang as Prod
type OptimizeGrammar = SomeComb
optimizeGrammar ::
- Trans (SomeComb repr) repr =>
+ Derivable (SomeComb repr) =>
SomeComb repr a -> repr a
-optimizeGrammar = trans
+optimizeGrammar = derive
-- * Data family 'Comb'
-- | 'Comb'inators of the 'Grammar'.
data family Comb
(comb :: ReprComb -> Constraint)
:: ReprComb -> ReprComb
+type instance Derived (Comb comb repr) = repr
-- | Convenient utility to pattern-match a 'SomeComb'.
pattern Comb :: Typeable comb => Comb comb repr a -> SomeComb repr a
-- this also give a more understandable code.
data SomeComb repr a =
forall comb.
- (Trans (Comb comb repr) repr, Typeable comb) =>
+ (Derivable (Comb comb repr), Typeable comb) =>
SomeComb (Comb comb repr a)
-instance Trans (SomeComb repr) repr where
- trans (SomeComb x) = trans x
+type instance Derived (SomeComb repr) = repr
+instance Derivable (SomeComb repr) where
+ derive (SomeComb x) = derive x
-- | @(unSomeComb c :: 'Maybe' ('Comb' comb repr a))@
-- extract the data-constructor from the given 'SomeComb'
Failure :: SomeFailure -> Comb CombAlternable repr a
Throw :: ExceptionLabel -> Comb CombAlternable repr a
Try :: SomeComb repr a -> Comb CombAlternable repr a
-instance CombAlternable repr => Trans (Comb CombAlternable repr) repr where
- trans = \case
- Alt exn x y -> alt exn (trans x) (trans y)
+instance CombAlternable repr => Derivable (Comb CombAlternable repr) where
+ derive = \case
+ Alt exn x y -> alt exn (derive x) (derive y)
Empty -> empty
Failure sf -> failure sf
Throw exn -> throw exn
- Try x -> try (trans x)
+ Try x -> try (derive x)
instance
( CombAlternable repr
, CombApplicable repr
pattern t :<$>: x <- Comb (Pure t) :<*>: x
pattern (:$>:) :: SomeComb repr a -> Production b -> Comb CombApplicable repr b
pattern x :$>: t <- x :*>: Comb (Pure t)
-instance CombApplicable repr => Trans (Comb CombApplicable repr) repr where
- trans = \case
+instance CombApplicable repr => Derivable (Comb CombApplicable repr) where
+ derive = \case
Pure x -> pure (optimizeProduction x)
- f :<*>: x -> trans f <*> trans x
- x :<*: y -> trans x <* trans y
- x :*>: y -> trans x *> trans y
+ f :<*>: x -> derive f <*> derive x
+ x :<*: y -> derive x <* derive y
+ x :*>: y -> derive x *> derive y
instance
( CombApplicable repr
, CombAlternable repr
data instance Comb CombFoldable repr a where
ChainPreC :: SomeComb repr (a -> a) -> SomeComb repr a -> Comb CombFoldable repr a
ChainPostC :: SomeComb repr a -> SomeComb repr (a -> a) -> Comb CombFoldable repr a
-instance CombFoldable repr => Trans (Comb CombFoldable repr) repr where
- trans = \case
- ChainPreC x y -> chainPre (trans x) (trans y)
- ChainPostC x y -> chainPost (trans x) (trans y)
+instance CombFoldable repr => Derivable (Comb CombFoldable repr) where
+ derive = \case
+ ChainPreC x y -> chainPre (derive x) (derive y)
+ ChainPostC x y -> chainPost (derive x) (derive y)
instance CombFoldable repr => CombFoldable (SomeComb repr) where
chainPre x = SomeComb . ChainPreC x
chainPost x = SomeComb . ChainPostC x
Ref :: Bool -> letName -> Comb (Letable letName) repr a
instance
Letable letName repr =>
- Trans (Comb (Letable letName) repr) repr where
- trans = \case
- Shareable n x -> shareable n (trans x)
+ Derivable (Comb (Letable letName) repr) where
+ derive = \case
+ Shareable n x -> shareable n (derive x)
Ref isRec n -> ref isRec n
instance
(Letable letName repr, Typeable letName) =>
SomeComb repr a -> Comb (Letsable letName) repr a
instance
Letsable letName repr =>
- Trans (Comb (Letsable letName) repr) repr where
- trans = \case
- Lets defs x -> lets ((\(SomeLet sub) -> SomeLet (trans sub)) Functor.<$> defs) (trans x)
+ Derivable (Comb (Letsable letName) repr) where
+ derive = \case
+ Lets defs x -> lets ((\(SomeLet sub) -> SomeLet (derive sub)) Functor.<$> defs) (derive x)
instance
(Letsable letName repr, Typeable letName) =>
Letsable letName (SomeComb repr) where
Look :: SomeComb repr a -> Comb CombLookable repr a
NegLook :: SomeComb repr a -> Comb CombLookable repr ()
Eof :: Comb CombLookable repr ()
-instance CombLookable repr => Trans (Comb CombLookable repr) repr where
- trans = \case
- Look x -> look (trans x)
- NegLook x -> negLook (trans x)
+instance CombLookable repr => Derivable (Comb CombLookable repr) where
+ derive = \case
+ Look x -> look (derive x)
+ NegLook x -> negLook (derive x)
Eof -> eof
instance
( CombAlternable repr
[SomeComb repr b] ->
SomeComb repr b ->
Comb CombMatchable repr b
-instance CombMatchable repr => Trans (Comb CombMatchable repr) repr where
- trans = \case
+instance CombMatchable repr => Derivable (Comb CombMatchable repr) where
+ derive = \case
Conditional a ps bs b ->
- conditional (trans a)
+ conditional (derive a)
(optimizeProduction Functor.<$> ps)
- (trans Functor.<$> bs) (trans b)
+ (derive Functor.<$> bs) (derive b)
instance
( CombApplicable repr
, CombAlternable repr
Comb (CombSatisfiable tok) repr tok
instance
CombSatisfiable tok repr =>
- Trans (Comb (CombSatisfiable tok) repr) repr where
- trans = \case
+ Derivable (Comb (CombSatisfiable tok) repr) where
+ derive = \case
SatisfyOrFail fs p -> satisfyOrFail fs (optimizeProduction p)
instance
(CombSatisfiable tok repr, Typeable tok) =>
SomeComb repr (a -> c) ->
SomeComb repr (b -> c) ->
Comb CombSelectable repr c
-instance CombSelectable repr => Trans (Comb CombSelectable repr) repr where
- trans = \case
- Branch lr l r -> branch (trans lr) (trans l) (trans r)
+instance CombSelectable repr => Derivable (Comb CombSelectable repr) where
+ derive = \case
+ Branch lr l r -> branch (derive lr) (derive l) (derive r)
instance
( CombApplicable repr
, CombAlternable repr
import Symantic.Typed.Data
import Symantic.Typed.Lang
-import Symantic.Typed.Optim
-import Symantic.Typed.Trans
+import Symantic.Typed.Optimize
+import Symantic.Typed.Derive
type Production = Product
(SomeData Identity)
{-# INLINE runValue #-}
runValue :: Production a -> a
-runValue x = runIdentity (trans x)
+runValue (Pair v _c) = runIdentity (derive v)
{-# INLINE runCode #-}
runCode :: Production a -> TH.CodeQ a
-runCode = trans
+runCode (Pair _v c) = derive c
-- Missing instances in 'Language.Haskell.TH',
-- needed for 'prodCon'.
[| production $(return (TH.ConE n))
(TH.unsafeCodeCoerce (return (TH.ConE $(TH.lift n)))) |]
-instance Trans Production Identity where
- trans (Pair (SomeData v) _c) = trans v
-instance Trans Production TH.CodeQ where
- trans (Pair _v (SomeData c)) = trans c
-
instance Show (SomeData TH.CodeQ a) where
- -- The 'Trans' constraint contained in 'SomeData'
+ -- The 'Derivable' constraint contained in 'SomeData'
-- is 'TH.CodeQ', hence 'Symantic.Typed.View' cannot be used here.
-- Fortunately 'TH.showCode' can be implemented.
- showsPrec p = showString Fun.. TH.showCode p Fun.. trans
+ showsPrec p = showString Fun.. TH.showCode p Fun.. derive
instance (Abstractable f, Abstractable g) => Abstractable (Product f g) where
-- Those 'undefined' are not unreachables by 'f'
import qualified Data.List as List
import qualified Data.Tree as Tree
-import Symantic.Typed.Letable
+import Symantic.Typed.ObserveSharing
import Symantic.Parser.Grammar.Combinators
import qualified Symantic.Parser.Grammar.Production as Prod
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
-import Symantic.Typed.Letable
+import Symantic.Typed.ObserveSharing
+import Symantic.Typed.Fixity
import Symantic.Parser.Grammar.Combinators
-import Symantic.Parser.Grammar.Fixity
-- * Type 'WriteGrammar'
newtype WriteGrammar (showName::Bool) a = WriteGrammar { unWriteGrammar ::
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-import Symantic.Typed.Letable
-import Symantic.Typed.Trans
+import Symantic.Typed.Derive
+import Symantic.Typed.ObserveSharing
import Symantic.Parser.Grammar.Combinators (Exception(..), Failure(..), SomeFailure(..), inputTokenProxy)
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
import qualified Language.Haskell.TH.HideName as TH
import qualified Symantic.Typed.Lang as Prod
-import qualified Symantic.Typed.Optim as Prod
+import qualified Symantic.Typed.Optimize as Prod
--import Debug.Trace
-- | Convenient utility to generate some final 'TH.CodeQ'.
genCode :: Splice a -> CodeQ a
-genCode = trans . Prod.normalOrderReduction
+genCode = derive . Prod.normalOrderReduction
-- * Type 'Gen'
-- | Generate the 'CodeQ' parsing the input.
import qualified Data.Functor as Functor
import qualified Language.Haskell.TH as TH
+import Symantic.Typed.Derive
import Symantic.Parser.Grammar
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
-import Symantic.Typed.Trans
-- * Data family 'Instr'
-- | 'Instr'uctions of the 'Machine'.
data family Instr
(instr :: ReprInstr -> Constraint)
:: ReprInstr -> ReprInstr
+type instance Derived (Instr instr repr inp vs) = repr inp vs
-- | Convenient utility to pattern-match a 'SomeInstr'.
pattern Instr :: Typeable comb =>
-- this also give a more undestandable code.
data SomeInstr repr inp vs a =
forall instr.
- ( Trans (Instr instr repr inp vs) (repr inp vs)
+ ( Derivable (Instr instr repr inp vs)
, Typeable instr
) =>
SomeInstr (Instr instr repr inp vs a)
-instance Trans (SomeInstr repr inp vs) (repr inp vs) where
- trans (SomeInstr x) = trans x
+type instance Derived (SomeInstr repr inp vs) = repr inp vs
+instance Derivable (SomeInstr repr inp vs) where
+ derive (SomeInstr x) = derive x
-- | @(unSomeInstr i :: 'Maybe' ('Instr' comb repr inp vs a))@
-- extract the data-constructor from the given 'SomeInstr'
SwapValue ::
SomeInstr repr inp (x ': y ': vs) a ->
Instr InstrValuable repr inp (y ': x ': vs) a
-instance InstrValuable repr => Trans (Instr InstrValuable repr inp vs) (repr inp vs) where
- trans = \case
- PushValue x k -> pushValue x (trans k)
- PopValue k -> popValue (trans k)
- Lift2Value f k -> lift2Value f (trans k)
- SwapValue k -> swapValue (trans k)
+instance InstrValuable repr => Derivable (Instr InstrValuable repr inp vs) where
+ derive = \case
+ PushValue x k -> pushValue x (derive k)
+ PopValue k -> popValue (derive k)
+ Lift2Value f k -> lift2Value f (derive k)
+ SwapValue k -> swapValue (derive k)
instance InstrValuable repr => InstrValuable (SomeInstr repr) where
-- 'PopValue' after a 'PushValue' is a no-op.
pushValue _v (Instr (PopValue i)) = i
SomeInstr repr inp vs ret ->
SomeInstr repr inp (Cursor inp ': vs) ret ->
Instr InstrExceptionable repr inp vs ret
-instance InstrExceptionable repr => Trans (Instr InstrExceptionable repr inp vs) (repr inp vs) where
- trans = \case
+instance InstrExceptionable repr => Derivable (Instr InstrExceptionable repr inp vs) where
+ derive = \case
Raise exn -> raise exn
Fail fs -> fail fs
- Commit exn k -> commit exn (trans k)
- Catch exn l r -> catch exn (trans l) (trans r)
+ Commit exn k -> commit exn (derive k)
+ Catch exn l r -> catch exn (derive l) (derive r)
instance InstrExceptionable repr => InstrExceptionable (SomeInstr repr) where
raise = SomeInstr . Raise
fail = SomeInstr . Fail
[SomeInstr repr inp vs a] ->
SomeInstr repr inp vs a ->
Instr InstrBranchable repr inp (v ': vs) a
-instance InstrBranchable repr => Trans (Instr InstrBranchable repr inp vs) (repr inp vs) where
- trans = \case
- CaseBranch l r -> caseBranch (trans l) (trans r)
- ChoicesBranch ps bs d -> choicesBranch ps (trans Functor.<$> bs) (trans d)
+instance InstrBranchable repr => Derivable (Instr InstrBranchable repr inp vs) where
+ derive = \case
+ CaseBranch l r -> caseBranch (derive l) (derive r)
+ ChoicesBranch ps bs d -> choicesBranch ps (derive Functor.<$> bs) (derive d)
instance InstrBranchable repr => InstrBranchable (SomeInstr repr) where
caseBranch l = SomeInstr . CaseBranch l
choicesBranch ps bs = SomeInstr . ChoicesBranch ps bs
Jump ::
LetName a ->
Instr InstrCallable repr inp '[] a
-instance InstrCallable repr => Trans (Instr InstrCallable repr inp vs) (repr inp vs) where
- trans = \case
- DefLet subs k -> defLet ((\(SomeLet sub) -> SomeLet (trans sub)) Functor.<$> subs) (trans k)
+instance InstrCallable repr => Derivable (Instr InstrCallable repr inp vs) where
+ derive = \case
+ DefLet subs k -> defLet ((\(SomeLet sub) -> SomeLet (derive sub)) Functor.<$> subs) (derive k)
Jump n -> jump n
- Call n k -> call n (trans k)
+ Call n k -> call n (derive k)
Ret -> ret
instance InstrCallable repr => InstrCallable (SomeInstr repr) where
defLet subs = SomeInstr . DefLet subs
RefJoin ::
LetName v ->
Instr InstrJoinable repr inp (v ': vs) a
-instance InstrJoinable repr => Trans (Instr InstrJoinable repr inp vs) (repr inp vs) where
- trans = \case
- DefJoin n sub k -> defJoin n (trans sub) (trans k)
+instance InstrJoinable repr => Derivable (Instr InstrJoinable repr inp vs) where
+ derive = \case
+ DefJoin n sub k -> defJoin n (derive sub) (derive k)
RefJoin n -> refJoin n
instance InstrJoinable repr => InstrJoinable (SomeInstr repr) where
defJoin n sub = SomeInstr . DefJoin n sub
LoadInput ::
SomeInstr repr inp vs a ->
Instr InstrInputable repr inp (Cursor inp ': vs) a
-instance InstrInputable repr => Trans (Instr InstrInputable repr inp vs) (repr inp vs) where
- trans = \case
- PushInput k -> pushInput (trans k)
- LoadInput k -> loadInput (trans k)
+instance InstrInputable repr => Derivable (Instr InstrInputable repr inp vs) where
+ derive = \case
+ PushInput k -> pushInput (derive k)
+ LoadInput k -> loadInput (derive k)
instance InstrInputable repr => InstrInputable (SomeInstr repr) where
pushInput = SomeInstr . PushInput
loadInput = SomeInstr . LoadInput
Instr (InstrReadable tok) repr inp vs a
instance
( InstrReadable tok repr, tok ~ InputToken inp ) =>
- Trans (Instr (InstrReadable tok) repr inp vs) (repr inp vs) where
- trans = \case
- Read fs p k -> read fs p (trans k)
+ Derivable (Instr (InstrReadable tok) repr inp vs) where
+ derive = \case
+ Read fs p k -> read fs p (derive k)
instance
( InstrReadable tok repr, Typeable tok ) =>
InstrReadable tok (SomeInstr repr) where
import qualified Language.Haskell.TH.Syntax as TH
import qualified Symantic.Typed.Lang as Prod
+import Symantic.Typed.Derive
import Symantic.Parser.Grammar
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
import Symantic.Parser.Machine.Optimize
-import Symantic.Typed.Trans
-- * Type 'Program'
-- | A 'Program' is a tree of 'Instr'uctions,
Machinable (InputToken inp) repr =>
Program repr inp a ->
IO (repr inp '[] a)
-optimizeMachine (Program f) = trans Functor.<$> f @'[] ret
+optimizeMachine (Program f) = derive Functor.<$> f @'[] ret
-- * Class 'Machinable'
-- | All the 'Instr'uctions.
, InstrReadable (InputToken inp) repr
, Typeable (InputToken inp)
) =>
- Trans (Comb CombAlternable (Program repr inp)) (Program repr inp) where
- trans = \case
+ Derivable (Comb CombAlternable (Program repr inp)) where
+ derive = \case
Alt ExceptionFailure
(Comb (SatisfyOrFail _fs p :: Comb (CombSatisfiable (InputToken inp)) (Program repr inp) a))
(Comb (Failure sf)) ->
satisfyOrFail (Set.singleton sf) p
- Alt exn x y -> alt exn (trans x) (trans y)
+ Alt exn x y -> alt exn (derive x) (derive y)
Empty -> empty
Failure sf -> failure sf
Throw exn -> throw exn
- Try x -> try (trans x)
+ Try x -> try (derive x)
instance
( Cursorable (Cursor inp)
import Symantic.Parser.Grammar.ObserveSharing (ShowLetName(..))
import Symantic.Parser.Machine.Instructions
-import Symantic.Typed.Letable (SomeLet(..))
+import Symantic.Typed.ObserveSharing (SomeLet(..))
import Symantic.Parser.Machine.Generate
-- * Type 'ViewMachine'
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-module Symantic.Typed.Data where
-
-import Data.Kind (Constraint, Type)
-import Type.Reflection (Typeable, (:~~:)(..), eqTypeRep, typeRep)
-import Data.Bool (Bool)
-import Data.Either (Either)
-import Data.Maybe (Maybe)
-import qualified Data.Eq as Eq
-import qualified Data.Maybe as Maybe
-import qualified Data.Function as Fun
-
-import Symantic.Typed.Lang
-import Symantic.Typed.Trans
-
-data SomeData repr a =
- forall able.
- ( Trans (Data able repr) repr
- , Typeable able
- ) => SomeData (Data able repr a)
-
-instance Trans (SomeData repr) repr where
- trans (SomeData x) = trans x
-
-type TypedRepr = Type -> Type
-
--- TODO: neither data families nor data instances
--- can have phantom roles with GHC-9's RoleAnnotations,
--- hence 'Data.Coerce.coerce' cannot be used on them for now.
--- https://gitlab.haskell.org/ghc/ghc/-/issues/8177
--- https://gitlab.haskell.org/ghc/ghc/-/wikis/roles#proposal-roles-for-type-families
--- Would be useful for @Trans (Data able repr) (Data able repr')@ instances.
-data family Data
- (able :: TypedRepr -> Constraint)
- :: TypedRepr -> TypedRepr
---instance Trans (Data able repr) (Data able repr) where
--- trans = Fun.id
-
--- | Convenient utility to pattern-match a 'SomeData'.
-pattern Data :: Typeable able => Data able repr a -> SomeData repr a
-pattern Data x <- (unSomeData -> Maybe.Just x)
-
--- | @(unSomeData c :: 'Maybe' ('Data' able repr a))@
--- extract the data-constructor from the given 'SomeData'
--- iif. it belongs to the @('Data' able repr a)@ data-instance.
-unSomeData ::
- forall able repr a.
- Typeable able =>
- SomeData repr a -> Maybe (Data able repr a)
-unSomeData (SomeData (c::Data c repr a)) =
- case typeRep @able `eqTypeRep` typeRep @c of
- Maybe.Just HRefl -> Maybe.Just c
- Maybe.Nothing -> Maybe.Nothing
-
--- Abstractable
-data instance Data Abstractable repr a where
- (:@) :: SomeData repr (a->b) -> SomeData repr a -> Data Abstractable repr b
- Lam :: (SomeData repr a -> SomeData repr b) -> Data Abstractable repr (a->b)
- Lam1 :: (SomeData repr a -> SomeData repr b) -> Data Abstractable repr (a->b)
- Var :: repr a -> Data Abstractable repr a
- -- FIXME: add constructors
-instance
- ( Abstractable repr
- --, Trans (SomeData repr) repr
- --, Trans repr (SomeData repr)
- ) => Trans (Data Abstractable repr) repr where
- trans = \case
- f :@ x -> trans f .@ trans x
- Lam f -> lam (\x -> trans (f (SomeData (Var x))))
- Lam1 f -> lam1 (\x -> trans (f (SomeData (Var x))))
- Var x -> var x
-instance
- ( Abstractable repr
- --, Trans (SomeData repr) repr
- --, Trans repr (SomeData repr)
- ) => Abstractable (SomeData repr) where
- f .@ x = SomeData (f :@ x)
- lam f = SomeData (Lam f)
- lam1 f = SomeData (Lam1 f)
- var = Fun.id
- ($) = lam1 (\f -> lam1 (\x -> f .@ x))
- (.) = lam1 (\f -> lam1 (\g -> lam1 (\x -> f .@ (g .@ x))))
- const = lam1 (\x -> lam1 (\_y -> x))
- flip = lam1 (\f -> lam1 (\x -> lam1 (\y -> f .@ y .@ x)))
- id = lam1 (\x -> x)
-
-{-
-instance
- ( Abstractable repr
- ) =>
- Abstractable (Data Abstractable repr) where
- var = Var Fun.. SomeData
- f .@ x = SomeData f :@ SomeData x
- lam f = Lam (SomeData Fun.. f Fun.. Var)
- lam1 f = Lam1 (SomeData Fun.. f Fun.. Var)
- ($) = lam1 (\f -> lam1 (\x -> f .@ x))
- (.) = lam1 (\f -> lam1 (\g -> lam1 (\x -> f .@ (g .@ x))))
- const = lam1 (\x -> lam1 (\_y -> x))
- flip = lam1 (\f -> lam1 (\x -> lam1 (\y -> f .@ y .@ x)))
- id = lam1 (\x -> x)
--}
-{-
-instance Bottomable repr => Morph (SomeData repr) (SomeData Unit) where
- morph (SomeData x) = morph x
-instance Bottomable repr => Morph (SomeData Unit) (SomeData repr) where
- morph (SomeData x) = morph x
-instance Abstractable Unit where
- (.@) _f _x = Unit
- lam _f = Unit
- lam1 _f = Unit
- ($) = Unit
- (.) = Unit
- const = Unit
- flip = Unit
- id = Unit
-instance Abstractable (Data Abstractable Unit) where
- f .@ x = SomeData f :@ SomeData x
- lam f = Lam (\(SomeData x) -> SomeData (f (trans x)))
- lam1 f = Lam1 (\(SomeData x) -> SomeData (f (trans x)))
- ($) = ($)
- (.) = (.)
- const = const
- flip = flip
- id = id
--}
-
--- Anythingable
-data instance Data Anythingable repr a where
- Anything :: repr a -> Data Anythingable repr a
-instance
- ( Anythingable repr
- ) =>
- Trans (Data Anythingable repr) repr where
- trans = \case
- Anything x -> anything x
-instance Anythingable (SomeData repr)
-instance Anythingable (Data Anythingable repr)
-
--- Bottomable
-class Bottomable repr where
- bottom :: repr a
-data instance Data Bottomable repr a where
- Bottom :: Data Bottomable repr a
-instance Bottomable repr => Trans (Data Bottomable repr) repr where
- trans Bottom{} = bottom
-
--- Constantable
-data instance Data (Constantable c) repr a where
- Constant :: {-Typeable c =>-} c -> Data (Constantable c) repr c
-instance Constantable c repr => Trans (Data (Constantable c) repr) repr where
- trans = \case
- Constant x -> constant x
-instance
- ( Constantable c repr
- , Typeable c
- ) => Constantable c (SomeData repr) where
- constant c = SomeData (Constant c)
-instance {-Typeable c =>-} Constantable c (Data (Constantable c) repr) where
- constant = Constant
-
--- Eitherable
-data instance Data Eitherable repr a where
- Left :: Data Eitherable repr (l -> Either l r)
- Right :: Data Eitherable repr (r -> Either l r)
-instance Eitherable repr => Trans (Data Eitherable repr) repr where
- trans = \case
- Left -> left
- Right -> right
-instance
- ( Eitherable repr
- ) => Eitherable (SomeData repr) where
- left = SomeData Left
- right = SomeData Right
-instance Eitherable (Data Eitherable repr) where
- left = Left
- right = Right
-
--- Equalable
-data instance Data Equalable repr a where
- Equal :: Eq.Eq a => Data Equalable repr (a -> a -> Bool)
-instance Equalable repr => Trans (Data Equalable repr) repr where
- trans = \case
- Equal -> equal
-instance
- ( Equalable repr
- ) => Equalable (SomeData repr) where
- equal = SomeData Equal
-instance Equalable (Data Equalable repr) where
- equal = Equal
-
--- IfThenElseable
-data instance Data IfThenElseable repr a where
- IfThenElse ::
- SomeData repr Bool ->
- SomeData repr a ->
- SomeData repr a ->
- Data IfThenElseable repr a
-instance IfThenElseable repr => Trans (Data IfThenElseable repr) repr where
- trans = \case
- IfThenElse test ok ko -> ifThenElse (trans test) (trans ok) (trans ko)
-instance
- ( IfThenElseable repr
- ) => IfThenElseable (SomeData repr) where
- ifThenElse test ok ko = SomeData (IfThenElse test ok ko)
-instance IfThenElseable repr => IfThenElseable (Data IfThenElseable repr) where
- ifThenElse test ok ko = IfThenElse (SomeData test) (SomeData ok) (SomeData ko)
-
--- Listable
-data instance Data Listable repr a where
- Cons :: Data Listable repr (a -> [a] -> [a])
- Nil :: Data Listable repr [a]
-infixr 4 `Cons`
-instance Listable repr => Trans (Data Listable repr) repr where
- trans = \case
- Cons -> cons
- Nil -> nil
-instance
- ( Listable repr
- ) => Listable (SomeData repr) where
- cons = SomeData Cons
- nil = SomeData Nil
-instance Listable (Data Listable repr) where
- cons = Cons
- nil = Nil
-
--- Maybeable
-data instance Data Maybeable repr a where
- Nothing :: Data Maybeable repr (Maybe a)
- Just :: Data Maybeable repr (a -> Maybe a)
-instance Maybeable repr => Trans (Data Maybeable repr) repr where
- trans = \case
- Nothing -> nothing
- Just -> just
-instance
- ( Maybeable repr
- ) => Maybeable (SomeData repr) where
- nothing = SomeData Nothing
- just = SomeData Just
-instance Maybeable (Data Maybeable repr) where
- nothing = Nothing
- just = Just
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-module Symantic.Typed.Lang where
-
-import Data.Char (Char)
-import Data.Bool (Bool(..))
-import Data.Either (Either(..))
-import Data.Eq (Eq)
-import Data.Maybe (Maybe(..))
-import qualified Data.Function as Fun
-
-import Symantic.Typed.Trans
-
-class Abstractable repr where
- -- | Application, aka. unabstract.
- (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
- -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
- lam :: (repr a -> repr b) -> repr (a->b)
- -- | Like 'lam' but whose argument is used only once,
- -- hence safe to beta-reduce (inline) without duplicating work.
- lam1 :: (repr a -> repr b) -> repr (a->b)
- const :: repr (a -> b -> a)
- flip :: repr ((a -> b -> c) -> b -> a -> c)
- id :: repr (a->a)
- (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
- ($) :: repr ((a->b) -> a -> b); infixr 0 $
- var :: repr a -> repr a
- default (.@) ::
- Liftable2 repr => Abstractable (Unlifted repr) =>
- repr (a->b) -> repr a -> repr b
- default lam ::
- Liftable repr => Unliftable repr => Abstractable (Unlifted repr) =>
- (repr a -> repr b) -> repr (a->b)
- default lam1 ::
- Liftable repr => Unliftable repr => Abstractable (Unlifted repr) =>
- (repr a -> repr b) -> repr (a->b)
- default const ::
- Liftable repr => Abstractable (Unlifted repr) =>
- repr (a -> b -> a)
- default flip ::
- Liftable repr => Abstractable (Unlifted repr) =>
- repr ((a -> b -> c) -> b -> a -> c)
- default id ::
- Liftable repr => Abstractable (Unlifted repr) =>
- repr (a->a)
- default (.) ::
- Liftable repr => Abstractable (Unlifted repr) =>
- repr ((b->c) -> (a->b) -> a -> c)
- default ($) ::
- Liftable repr => Abstractable (Unlifted repr) =>
- repr ((a->b) -> a -> b)
- default var ::
- Liftable1 repr => Abstractable (Unlifted repr) =>
- repr a -> repr a
- (.@) = lift2 (.@)
- lam f = lift (lam (trans Fun.. f Fun.. trans))
- lam1 f = lift (lam1 (trans Fun.. f Fun.. trans))
- const = lift const
- flip = lift flip
- id = lift id
- (.) = lift (.)
- ($) = lift ($)
- var = lift1 var
-class Anythingable repr where
- anything :: repr a -> repr a
- anything = Fun.id
-class Constantable c repr where
- constant :: c -> repr c
- default constant ::
- Liftable repr => Constantable c (Unlifted repr) =>
- c -> repr c
- constant = lift Fun.. constant
-bool :: Constantable Bool repr => Bool -> repr Bool
-bool = constant @Bool
-char :: Constantable Char repr => Char -> repr Char
-char = constant @Char
-unit :: Constantable () repr => repr ()
-unit = constant @() ()
-class Eitherable repr where
- left :: repr (l -> Either l r)
- right :: repr (r -> Either l r)
- default left ::
- Liftable repr => Eitherable (Unlifted repr) =>
- repr (l -> Either l r)
- default right ::
- Liftable repr => Eitherable (Unlifted repr) =>
- repr (r -> Either l r)
- left = lift left
- right = lift right
-class Equalable repr where
- equal :: Eq a => repr (a -> a -> Bool)
- default equal ::
- Liftable repr => Equalable (Unlifted repr) =>
- Eq a => repr (a -> a -> Bool)
- equal = lift equal
-infix 4 `equal`, ==
-(==) :: (Abstractable repr, Equalable repr, Eq a) => repr (a -> a -> Bool)
-(==) = lam (\x -> lam (\y -> equal .@ x .@ y))
-class IfThenElseable repr where
- ifThenElse :: repr Bool -> repr a -> repr a -> repr a
- default ifThenElse ::
- Liftable3 repr => IfThenElseable (Unlifted repr) =>
- repr Bool -> repr a -> repr a -> repr a
- ifThenElse = lift3 ifThenElse
-class Listable repr where
- cons :: repr (a -> [a] -> [a])
- nil :: repr [a]
- default cons ::
- Liftable repr => Listable (Unlifted repr) =>
- repr (a -> [a] -> [a])
- default nil ::
- Liftable repr => Listable (Unlifted repr) =>
- repr [a]
- cons = lift cons
- nil = lift nil
-class Maybeable repr where
- nothing :: repr (Maybe a)
- just :: repr (a -> Maybe a)
- default nothing ::
- Liftable repr => Maybeable (Unlifted repr) =>
- repr (Maybe a)
- default just ::
- Liftable repr => Maybeable (Unlifted repr) =>
- repr (a -> Maybe a)
- nothing = lift nothing
- just = lift just
+++ /dev/null
-{-# LANGUAGE AllowAmbiguousTypes #-} -- For ShowLetName
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE ExistentialQuantification #-} -- For SharingName
--- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#
-module Symantic.Typed.Letable where
-
-import Control.Applicative (Applicative(..))
-import Control.Monad (Monad(..))
-import Data.Bool (Bool(..))
-import Data.Eq (Eq(..))
-import Data.Foldable (foldMap)
-import Data.Function (($), (.))
-import Data.Functor ((<$>))
-import Data.Functor.Compose (Compose(..))
-import Data.HashMap.Strict (HashMap)
-import Data.HashSet (HashSet)
-import Data.Hashable (Hashable, hashWithSalt, hash)
-import Data.Int (Int)
-import Data.Maybe (Maybe(..), isNothing)
-import Data.Monoid (Monoid(..))
-import Data.Ord (Ord(..))
-import Data.String (String)
--- import GHC.Exts (Int(..))
--- import GHC.Prim (unsafeCoerce#)
-import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)
--- import Numeric (showHex)
-import Prelude ((+), error)
-import System.IO (IO)
-import System.IO.Unsafe (unsafePerformIO)
-import Text.Show (Show(..))
-import qualified Control.Monad.Trans.Class as MT
-import qualified Control.Monad.Trans.Reader as MT
-import qualified Control.Monad.Trans.State as MT
-import qualified Control.Monad.Trans.Writer as MT
-import qualified Data.HashMap.Strict as HM
-import qualified Data.HashSet as HS
-
-import Symantic.Typed.Trans
-
---import Debug.Trace (trace)
-
--- * Class 'Letable'
--- | This class is not for end-users like usual symantic operators,
--- here 'shareable' and 'ref' are introduced by 'observeSharing'.
-class Letable letName repr where
- -- | @('ref' isRec letName)@ is a reference to @(letName)@.
- -- @(isRec)@ is 'True' iif. this 'ref'erence is recursive,
- -- ie. is reachable within its 'def'inition.
- ref :: Bool -> letName -> repr a
- default ref ::
- Liftable repr => Letable letName (Unlifted repr) =>
- Bool -> letName -> repr a
- ref isRec n = lift (ref isRec n)
-
- -- | @('shareable' letName x)@ let-binds @(letName)@ to be equal to @(x)@.
- shareable :: letName -> repr a -> repr a
- default shareable ::
- Liftable1 repr => Letable letName (Unlifted repr) =>
- letName -> repr a -> repr a
- shareable n = lift1 (shareable n)
-
--- * Class 'MakeLetName'
-class MakeLetName letName where
- makeLetName :: SharingName -> IO letName
-
--- ** Type 'ShowLetName'
--- | Useful on golden unit tests because 'StableName'
--- change often when changing unrelated source code
--- or even changing basic GHC or executable flags.
-class ShowLetName (showName::Bool) letName where
- showLetName :: letName -> String
--- | Like 'Show'.
-instance Show letName => ShowLetName 'True letName where
- showLetName = show
--- | Always return @"<hidden>"@,
-instance ShowLetName 'False letName where
- showLetName _p = "<hidden>"
-
--- * Type 'SharingName'
--- | Note that the observable sharing enabled by 'StableName'
--- is not perfect as it will not observe all the sharing explicitely done.
---
--- Note also that the observed sharing could be different between ghc and ghci.
-data SharingName = forall a. SharingName (StableName a)
--- | @('makeSharingName' x)@ is like @('makeStableName' x)@ but it also forces
--- evaluation of @(x)@ to ensure that the 'StableName' is correct first time,
--- which avoids to produce a tree bigger than needed.
---
--- Note that this function uses 'unsafePerformIO' instead of returning in 'IO',
--- this is apparently required to avoid infinite loops due to unstable 'StableName'
--- in compiled code, and sometimes also in ghci.
---
--- Note that maybe [pseq should be used here](https://gitlab.haskell.org/ghc/ghc/-/issues/2916).
-makeSharingName :: a -> SharingName
-makeSharingName !x = SharingName $ unsafePerformIO $ makeStableName x
-
-instance Eq SharingName where
- SharingName x == SharingName y = eqStableName x y
-instance Hashable SharingName where
- hash (SharingName n) = hashStableName n
- hashWithSalt salt (SharingName n) = hashWithSalt salt n
-{-
-instance Show SharingName where
- showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
--}
-
--- * Type 'ObserveSharing'
-newtype ObserveSharing letName repr a = ObserveSharing { unObserveSharing ::
- MT.ReaderT (HashSet SharingName)
- (MT.State (ObserveSharingState letName))
- (FinalizeSharing letName repr a) }
-
--- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
--- least once and/or recursively, in order to replace them
--- with the 'def' and 'ref' combinators.
--- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
---
--- Beware not to apply 'observeSharing' more than once on the same term
--- otherwise some 'shareable' introduced by the first call
--- would be removed by the second call.
-observeSharing ::
- Eq letName =>
- Hashable letName =>
- Show letName =>
- ObserveSharing letName repr a ->
- WithSharing letName repr a
-observeSharing (ObserveSharing m) =
- let (fs, st) = MT.runReaderT m mempty `MT.runState`
- ObserveSharingState
- { oss_refs = HM.empty
- , oss_recs = HS.empty
- } in
- let refs = HS.fromList $
- (`foldMap` oss_refs st) $ (\(letName, refCount) ->
- if refCount > 0 then [letName] else []) in
- --trace (show refs) $
- MT.runWriter $
- (`MT.runReaderT` refs) $
- unFinalizeSharing fs
-
--- ** Type 'SomeLet'
-data SomeLet repr = forall a. SomeLet (repr a)
-
--- ** Type 'WithSharing'
-type WithSharing letName repr a =
- (repr a, HM.HashMap letName (SomeLet repr))
-{-
--- * Type 'WithSharing'
-data WithSharing letName repr a = WithSharing
- { lets :: HM.HashMap letName (SomeLet repr)
- , body :: repr a
- }
-mapWithSharing ::
- (forall v. repr v -> repr v) ->
- WithSharing letName repr a ->
- WithSharing letName repr a
-mapWithSharing f ws = WithSharing
- { lets = (\(SomeLet repr) -> SomeLet (f repr)) <$> lets ws
- , body = f (body ws)
- }
--}
-
--- ** Type 'ObserveSharingState'
-data ObserveSharingState letName = ObserveSharingState
- { oss_refs :: HashMap SharingName (letName, Int)
- , oss_recs :: HashSet SharingName
- -- ^ TODO: unused so far, will it be useful somewhere at a later stage?
- }
-
-observeSharingNode ::
- Eq letName =>
- Hashable letName =>
- Show letName =>
- Letable letName repr =>
- MakeLetName letName =>
- ObserveSharing letName repr a ->
- ObserveSharing letName repr a
-observeSharingNode (ObserveSharing m) = ObserveSharing $ do
- let nodeName = makeSharingName m
- st <- MT.lift MT.get
- ((letName, before), preds) <- getCompose $ HM.alterF (\before ->
- Compose $ case before of
- Nothing -> do
- let letName = unsafePerformIO $ makeLetName nodeName
- return ((letName, before), Just (letName, 0))
- Just (letName, refCount) -> do
- return ((letName, before), Just (letName, refCount + 1))
- ) nodeName (oss_refs st)
- parentNames <- MT.ask
- if nodeName `HS.member` parentNames
- then do
- MT.lift $ MT.put st
- { oss_refs = preds
- , oss_recs = HS.insert nodeName (oss_recs st)
- }
- return $ ref True letName
- else do
- MT.lift $ MT.put st{ oss_refs = preds }
- if isNothing before
- then MT.local (HS.insert nodeName) (shareable letName <$> m)
- else return $ ref False letName
-
-type instance Unlifted (ObserveSharing letName repr) = FinalizeSharing letName repr
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Show letName
- ) => Trans (FinalizeSharing letName repr) (ObserveSharing letName repr) where
- trans = observeSharingNode . ObserveSharing . return
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Show letName
- ) => Trans1 (FinalizeSharing letName repr) (ObserveSharing letName repr) where
- trans1 f x = observeSharingNode $ ObserveSharing $
- f <$> unObserveSharing x
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Show letName
- ) => Trans2 (FinalizeSharing letName repr) (ObserveSharing letName repr) where
- trans2 f x y = observeSharingNode $ ObserveSharing $
- f <$> unObserveSharing x
- <*> unObserveSharing y
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Show letName
- ) => Trans3 (FinalizeSharing letName repr) (ObserveSharing letName repr) where
- trans3 f x y z = observeSharingNode $ ObserveSharing $
- f <$> unObserveSharing x
- <*> unObserveSharing y
- <*> unObserveSharing z
-instance Letable letName (ObserveSharing letName repr) where
- shareable = error "[BUG]: observeSharing MUST NOT be applied twice"
- ref = error "[BUG]: observeSharing MUST NOT be applied twice"
-instance Letsable letName (ObserveSharing letName repr) where
- lets = error "[BUG]: observeSharing MUST NOT be applied twice"
-
--- * Type 'FinalizeSharing'
--- | Remove 'shareable' when non-recursive or unused
--- or replace it by 'ref', moving 'def' a top.
-newtype FinalizeSharing letName repr a = FinalizeSharing { unFinalizeSharing ::
- MT.ReaderT (HS.HashSet letName)
- (MT.Writer (LetBindings letName repr))
- (repr a) }
-
--- ** Type 'LetBindings'
-type LetBindings letName repr = HM.HashMap letName (SomeLet repr)
-
-type instance Unlifted (FinalizeSharing _letName repr) = repr
-instance
- ( Eq letName
- , Hashable letName
- ) => Trans repr (FinalizeSharing letName repr) where
- trans = FinalizeSharing . pure
-instance
- ( Eq letName
- , Hashable letName
- ) => Trans1 repr (FinalizeSharing letName repr) where
- trans1 f x = FinalizeSharing $ f <$> unFinalizeSharing x
-instance
- ( Eq letName
- , Hashable letName
- ) => Trans2 repr (FinalizeSharing letName repr) where
- trans2 f x y = FinalizeSharing $
- f <$> unFinalizeSharing x
- <*> unFinalizeSharing y
-instance
- ( Eq letName
- , Hashable letName
- ) => Trans3 repr (FinalizeSharing letName repr) where
- trans3 f x y z = FinalizeSharing $
- f <$> unFinalizeSharing x
- <*> unFinalizeSharing y
- <*> unFinalizeSharing z
-instance
- ( Letable letName repr
- , Eq letName
- , Hashable letName
- , Show letName
- ) => Letable letName (FinalizeSharing letName repr) where
- shareable name x = FinalizeSharing $ do
- refs <- MT.ask
- if name `HS.member` refs
- -- This 'shareable' is 'ref'erenced, move it into the result,
- -- to put it in scope even when some 'ref' to it exists outside of 'x'
- -- (which can happen when a sub-expression is shared),
- -- and replace it by a 'ref'.
- then do
- let (repr, defs) = MT.runWriter $ MT.runReaderT (unFinalizeSharing x) refs
- MT.lift $ MT.tell $ HM.insert name (SomeLet repr) defs
- return $ ref False name
- -- Remove 'shareable'.
- else
- unFinalizeSharing x
-
--- * Class 'Letsable'
-class Letsable letName repr where
- -- | @('lets' defs x)@ let-binds @(defs)@ in @(x)@.
- lets :: LetBindings letName repr -> repr a -> repr a
- default lets ::
- Trans repr (Unlifted repr) =>
- Liftable1 repr => Letsable letName (Unlifted repr) =>
- LetBindings letName repr -> repr a -> repr a
- lets defs = lift1 (lets ((\(SomeLet val) -> SomeLet (trans val)) <$> defs))
-{-
--- | Not used but can be written nonetheless.
-instance
- ( Letsable letName repr
- , Eq letName
- , Hashable letName
- , Show letName
- ) => Letsable letName (FinalizeSharing letName repr) where
- lets defs x = FinalizeSharing $ do
- ds <- traverse (\(SomeLet v) -> do
- r <- unFinalizeSharing v
- return (SomeLet r)
- ) defs
- MT.lift $ MT.tell ds
- unFinalizeSharing x
--}
+++ /dev/null
-module Symantic.Typed.Optim where
-
-import Data.Bool (Bool)
-import qualified Data.Function as Fun
-import Symantic.Typed.Lang
-import Symantic.Typed.Data
-
--- | Beta-reduce the left-most outer-most lambda abstraction (aka. normal-order reduction),
--- but to avoid duplication of work, only those manually marked
--- as using their variable at most once.
---
--- DOC: Demonstrating Lambda Calculus Reduction, Peter Sestoft, 2001,
--- https://www.itu.dk/people/sestoft/papers/sestoft-lamreduce.pdf
-normalOrderReduction :: forall repr a.
- Abstractable repr =>
- IfThenElseable repr =>
- SomeData repr a -> SomeData repr a
-normalOrderReduction = nor
- where
- -- | normal-order reduction
- nor :: SomeData repr b -> SomeData repr b
- nor = \case
- Data (Lam f) -> lam (nor Fun.. f)
- Data (Lam1 f) -> lam1 (nor Fun.. f)
- Data (x :@ y) -> case whnf x of
- Data (Lam1 f) -> nor (f y)
- x' -> nor x' .@ nor y
- Data (IfThenElse test ok ko) ->
- case nor test of
- Data (Constant b :: Data (Constantable Bool) repr Bool) ->
- if b then nor ok else nor ko
- t -> ifThenElse (nor t) (nor ok) (nor ko)
- x -> x
- -- | weak-head normal-form
- whnf :: SomeData repr b -> SomeData repr b
- whnf = \case
- Data (x :@ y) -> case whnf x of
- Data (Lam1 f) -> whnf (f y)
- x' -> x' .@ y
- x -> x
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-} -- For type class synonyms
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE DefaultSignatures #-} -- For adding Trans constraints
-module Symantic.Typed.Trans where
-
-import Data.Function ((.))
-import Data.Kind (Type)
-
--- * Type family 'Unlifted'
-type family Unlifted (repr :: Type -> Type) :: Type -> Type
-
--- * Class 'Trans'
--- | A 'trans'formation from an interpreter @(from)@ to an interpreter @(to)@.
-class Trans from to where
- trans :: from a -> to a
-
--- * Class 'BiTrans'
--- | Convenient type class synonym.
--- Note that this is not necessarily a bijective 'trans'lation,
--- a 'trans' being not necessarily injective nor surjective.
-type BiTrans from to = (Trans from to, Trans to from)
-
--- ** Class 'Liftable'
--- | Convenient type class synonym for using 'Unlifted'
-type Liftable repr = Trans (Unlifted repr) repr
-lift :: forall repr a.
- Liftable repr =>
- Unlifted repr a -> repr a
-lift = trans @(Unlifted repr)
-{-# INLINE lift #-}
-
-unlift :: forall repr a.
- Trans repr (Unlifted repr) =>
- repr a -> Unlifted repr a
-unlift = trans @repr
-{-# INLINE unlift #-}
-
--- ** Class 'Unliftable'
--- | Convenient type class synonym for using 'Unlifted'
-type Unliftable repr = Trans repr (Unlifted repr)
-
--- * Class 'Trans1'
-class Trans1 from to where
- trans1 ::
- (from a -> from b) ->
- to a -> to b
- default trans1 ::
- BiTrans from to =>
- (from a -> from b) ->
- to a -> to b
- trans1 f = trans . f . trans
- {-# INLINE trans1 #-}
-
--- ** Class 'Liftable1'
--- | Convenient type class synonym for using 'Unlifted'
-type Liftable1 repr = Trans1 (Unlifted repr) repr
-lift1 :: forall repr a b.
- Liftable1 repr =>
- (Unlifted repr a -> Unlifted repr b) ->
- repr a -> repr b
-lift1 = trans1 @(Unlifted repr)
-{-# INLINE lift1 #-}
-
--- * Class 'Trans2'
-class Trans2 from to where
- trans2 ::
- (from a -> from b -> from c) ->
- to a -> to b -> to c
- default trans2 ::
- BiTrans from to =>
- (from a -> from b -> from c) ->
- to a -> to b -> to c
- trans2 f a b = trans (f (trans a) (trans b))
- {-# INLINE trans2 #-}
-
--- ** Class 'Liftable2'
--- | Convenient type class synonym for using 'Unlifted'
-type Liftable2 repr = Trans2 (Unlifted repr) repr
-lift2 :: forall repr a b c.
- Liftable2 repr =>
- (Unlifted repr a -> Unlifted repr b -> Unlifted repr c) ->
- repr a -> repr b -> repr c
-lift2 = trans2 @(Unlifted repr)
-{-# INLINE lift2 #-}
-
--- * Class 'Trans3'
-class Trans3 from to where
- trans3 ::
- (from a -> from b -> from c -> from d) ->
- to a -> to b -> to c -> to d
- default trans3 ::
- BiTrans from to =>
- (from a -> from b -> from c -> from d) ->
- to a -> to b -> to c -> to d
- trans3 f a b c = trans (f (trans a) (trans b) (trans c))
- {-# INLINE trans3 #-}
-
--- ** Class 'Liftable3'
--- | Convenient type class synonym for using 'Unlifted'
-type Liftable3 repr = Trans3 (Unlifted repr) repr
-lift3 :: forall repr a b c d.
- Liftable3 repr =>
- (Unlifted repr a -> Unlifted repr b -> Unlifted repr c -> Unlifted repr d) ->
- repr a -> repr b -> repr c -> repr d
-lift3 = trans3 @(Unlifted repr)
-{-# INLINE lift3 #-}
-
-{-
--- * Type 'Any'
--- | A newtype to disambiguate the 'Trans' instance to any other interpreter when there is also one or more 'Trans's to other interpreters with a different interpretation than the generic one.
-newtype Any repr a = Any { unAny :: repr a }
-type instance Unlifted (Any repr) = repr
-instance Trans (Any repr) repr where
- trans = unAny
-instance Trans1 (Any repr) repr
-instance Trans2 (Any repr) repr
-instance Trans3 (Any repr) repr
-instance Trans repr (Any repr) where
- trans = Any
-instance Trans1 repr (Any repr)
-instance Trans2 repr (Any repr)
-instance Trans3 repr (Any repr)
--}
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ImplicitPrelude #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-} -- For Show (SomeData a)
-module Symantic.Typed.View where
-
-import Data.Int (Int)
-import Data.String
-import Text.Show
-import qualified Data.Function as Fun
-import qualified Prelude
-
-import Symantic.Parser.Grammar.Fixity
-import Symantic.Typed.Lang
-import Symantic.Typed.Data
-import Symantic.Typed.Trans
-
-data View a where
- View :: (ViewEnv -> ShowS) -> View a
- ViewUnifix :: Unifix -> String -> String -> View (a -> b)
- ViewInfix :: Infix -> String -> String -> View (a -> b -> c)
- ViewApp :: View (b -> a) -> View b -> View a
-
-runView :: View a -> ViewEnv -> ShowS
-runView (View v) env = v env
-runView (ViewInfix _op name _infixName) _env = showString name
-runView (ViewUnifix _op name _unifixName) _env = showString name
-runView (ViewApp f x) env =
- pairView env op Fun.$
- runView f env{viewEnv_op = (op, SideL) } Fun..
- showString " " Fun..
- runView x env{viewEnv_op = (op, SideR) }
- where op = infixN 10
-
--- | Unusual, but enables to leverage default definition of methods.
-type instance Unlifted View = View
-instance Trans View View where
- trans = Fun.id
-
-instance IsString (View a) where
- fromString s = View Fun.$ \_env -> showString s
-instance Show (View a) where
- showsPrec p = (`runView` ViewEnv
- { viewEnv_op = (infixN p, SideL)
- , viewEnv_pair = pairParen
- , viewEnv_lamDepth = 1
- })
-instance Show (SomeData View a) where
- showsPrec p (SomeData x) = showsPrec p (trans @_ @View x)
-
-data ViewEnv
- = ViewEnv
- { viewEnv_op :: (Infix, Side)
- , viewEnv_pair :: Pair
- , viewEnv_lamDepth :: Int
- }
-
-pairView :: ViewEnv -> Infix -> ShowS -> ShowS
-pairView env op s =
- if isPairNeeded (viewEnv_op env) op
- then showString o Fun.. s Fun.. showString c
- else s
- where (o,c) = viewEnv_pair env
-
-instance Abstractable View where
- var = Fun.id
- lam f = viewLam "x" f
- lam1 f = viewLam "u" f
- ViewInfix op _name infixName .@ ViewApp x y = View Fun.$ \env ->
- pairView env op Fun.$
- runView x env{viewEnv_op=(op, SideL)} Fun..
- showString " " Fun.. showString infixName Fun.. showString " " Fun..
- runView y env{viewEnv_op=(op, SideR)}
- ViewInfix op name _infixName .@ x = View Fun.$ \env ->
- showParen Prelude.True Fun.$
- runView x env{viewEnv_op=(op, SideL)} Fun..
- showString " " Fun.. showString name
- f .@ x = ViewApp f x
-viewLam :: String -> (View a -> View b) -> View (a -> b)
-viewLam varPrefix f = View Fun.$ \env ->
- pairView env op Fun.$
- let x = showString varPrefix Fun..
- showsPrec 0 (viewEnv_lamDepth env) in
- -- showString "Lam1 (" .
- showString "\\" Fun.. x Fun.. showString " -> " Fun..
- runView (f (View (\_env -> x))) env
- { viewEnv_op = (op, SideL)
- , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
- }
- -- . showString ")"
- where
- op = infixN 0
-instance Anythingable View
-instance Bottomable View where
- bottom = "<hidden>"
-instance Show c => Constantable c View where
- constant c = View Fun.$ \_env -> shows c
-instance Eitherable View where
- left = "Left"
- right = "Right"
-instance Equalable View where
- equal = ViewInfix (infixN 4) "(==)" "=="
-instance Listable View where
- cons = ViewInfix (infixR 5) "(:)" ":"
- nil = "[]"
-instance Maybeable View where
- nothing = "Nothing"
- just = "Just"
-Wincomplete-uni-patterns
-Wincomplete-record-updates
-Wpartial-fields
- -fhide-source-paths
- ---freverse-errors
-fprint-potential-instances
- ghc-prof-options: -eventlog -fprof-auto
- -- -fprof-auto-calls
library
import: boilerplate
Symantic.Parser
Symantic.Parser.Grammar
Symantic.Parser.Grammar.Combinators
- Symantic.Parser.Grammar.Fixity
Symantic.Parser.Grammar.ObserveSharing
Symantic.Parser.Grammar.Optimize
Symantic.Parser.Grammar.Production
Symantic.Parser.Machine.Optimize
Symantic.Parser.Machine.Program
Symantic.Parser.Machine.View
- Symantic.Typed.Data
- Symantic.Typed.Lang
- Symantic.Typed.Letable
- Symantic.Typed.Optim
- Symantic.Typed.Trans
- Symantic.Typed.View
default-extensions:
BangPatterns,
DataKinds,
deepseq >= 1.4,
ghc-prim,
hashable,
- -- Needed to use Language.Haskell.Ppr.Lib.pprExp
+ -- For Language.Haskell.Ppr.Lib.pprExp
pretty >= 1.1,
+ symantic-base >= 0.1,
template-haskell >= 2.16,
text,
transformers,
megaparsec >= 9.0,
process >= 1.6,
strict >= 0.4,
+ symantic-base >= 0.1,
tasty >= 0.11,
tasty-golden >= 2.3,
template-haskell >= 2.16,
sourcephile / git / haskell / symantic-parser.git / commitdiff