- 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.
-- No dependency upon GHC plugins: `lift-plugin` and `idioms-plugin`, 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 lifting Haskell code in `pure` to integrate the `TemplateHaskell` needed. 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`. 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 `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`.
- License is `AGPL-3-or-later` not `BSD-3-Clause`.
+- Some generated `TemplateHaskell` is 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.
import Data.Char (Char)
import Data.Function ((.))
-import qualified Language.Haskell.TH.Syntax as TH
import qualified Prelude
-import Data.Functor.Product (Product(..))
-import Symantic.Typed.Trans
import qualified Symantic.Parser as SP
import Parsers.Utils
import Control.DeepSeq (NFData)
import Data.Eq (Eq(..))
-import Data.Function (($), (.))
-import Data.Functor.Identity (Identity(..))
import GHC.Generics (Generic)
import Text.Show (Show(..))
-import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-import Symantic.Parser
data Instruction
= Forward
import qualified Data.Set as Set
import qualified Data.Text as Text
-import Symantic.Typed.Trans
import qualified Symantic.Parser as P
import qualified Symantic.Typed.Lang as Prod
{-# LANGUAGE TypeFamilies #-}
module Parsers.Utils.Handrolled where
-import Control.Monad (Monad(..), fail)
import Data.Bool (Bool)
import Data.Char (Char)
import Data.Maybe (Maybe(..))
+{-# OPTIONS_GHC -Wno-missing-methods #-} -- For TH.Quasi
-- | This module enables to 'showCode'
-- without requiring to be in 'IO'.
module Language.Haskell.TH.Show where
import Data.Function (($), (.))
-import Data.String (String, IsString(..))
+import Data.String (String)
import Prelude (Integer, error, succ)
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
showCode :: TH.CodeQ a -> String
showCode q = runShowQ $ do
- TH.runQ (TH.examineCode q) >>= return . TH.pprint . TH.unType
+ texp <- TH.runQ (TH.examineCode q)
+ return $ TH.pprint $ TH.unType texp
-- | The whole point of ShowQ is to remove the need for IO,
-- but GHC's 'TH.Quasi' class forces it...
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Ord (Ord(..))
-import Data.Functor (Functor)
-import Data.Functor.Identity (Identity(..))
-import Data.Functor.Product (Product(..))
-import Data.Function ((.), flip, id, const)
+import Data.Function ((.), flip, const)
import Data.Int (Int)
import Data.Kind (Type, Constraint)
import Data.Maybe (Maybe(..))
import qualified Data.Set as Set
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-import qualified Prelude
import qualified Symantic.Typed.Trans as Sym
import qualified Symantic.Typed.Lang as Prod
-import qualified Symantic.Typed.View
import Symantic.Parser.Grammar.Production
-- * Type 'ReprComb'
import qualified Data.Functor as Functor
import qualified Data.List as List
-import Symantic.Parser.Grammar.Combinators hiding (code)
+import Symantic.Parser.Grammar.Combinators
import Symantic.Parser.Grammar.Production
import Symantic.Typed.Letable
import Symantic.Typed.Trans
-import qualified Symantic.Parser.Grammar.Production as Prod
import qualified Symantic.Typed.Data as Prod
import qualified Symantic.Typed.Lang as Prod
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.Production where
import Control.Monad (Monad(..))
-import Data.Bool (Bool(..))
-import Data.Char (Char)
-import Data.Eq (Eq)
import Data.Functor.Identity (Identity(..))
import Data.Functor.Product (Product(..))
+import Data.Ord (Ord(..))
import Prelude (Num(..), undefined)
-import Text.Show (Show(..), showString)
+import Text.Show (Show(..), showParen, showString)
import Type.Reflection (Typeable)
import qualified Data.Either as Either
import qualified Data.Eq as Eq
import qualified Data.Maybe as Maybe
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
+import qualified Language.Haskell.TH.Show as TH
import Symantic.Typed.Data
import Symantic.Typed.Lang
import Symantic.Typed.Optim
-import Symantic.Typed.Reify
import Symantic.Typed.Trans
-import Symantic.Typed.View
-
-import Debug.Trace
type Production = Product
(SomeData Identity)
runCode :: Production a -> TH.CodeQ a
runCode = trans
--- Missing instances in Language.Haskell.TH
+-- Missing instances in 'Language.Haskell.TH',
+-- needed for 'prodCon'.
deriving instance TH.Lift TH.OccName
deriving instance TH.Lift TH.NameFlavour
deriving instance TH.Lift TH.ModName
prodCon name = do
info <- TH.reify name
case info of
- TH.DataConI n ty _pn ->
+ TH.DataConI n _ty _pn ->
[| production $(return (TH.ConE n))
(TH.unsafeCodeCoerce (return (TH.ConE $(TH.lift n)))) |]
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'
+ -- is 'TH.CodeQ', hence 'Symantic.Typed.View' cannot be used here.
+ -- Fortunately 'TH.showCode' can be implemented.
+ showsPrec p = showString Fun.. TH.showCode Fun.. trans
+
instance (Abstractable f, Abstractable g) => Abstractable (Product f g) where
-- Those 'undefined' are not unreachables by 'f'
-- but this is the cost to pay for defining this instance.
($) = Pair ($) ($)
instance (Num (f a), Num (g a)) => Num (Product f g a) where
Pair x1 x2 + Pair y1 y2 = Pair (x1 + y1) (x2 + y2)
+ Pair x1 x2 * Pair y1 y2 = Pair (x1 * y1) (x2 * y2)
+ Pair x1 x2 - Pair y1 y2 = Pair (x1 - y1) (x2 - y2)
+ abs (Pair x1 x2) = Pair (abs x1) (abs x2)
+ fromInteger i = Pair (fromInteger i) (fromInteger i)
+ negate (Pair x1 x2) = Pair (negate x1) (negate x2)
+ signum (Pair x1 x2) = Pair (signum x1) (signum x2)
instance (Eitherable f, Eitherable g) => Eitherable (Product f g) where
left = Pair left left
right = Pair right right
just = [|| Maybe.Just ||]
instance Num a => Num (TH.CodeQ a) where
x + y = [|| $$x + $$y||]
+ x * y = [|| $$x * $$y||]
+ x - y = [|| $$x - $$y||]
+ abs x = [|| abs $$x ||]
+ fromInteger i = [|| fromInteger $$(TH.liftTyped i) ||]
+ negate x = [|| negate $$x ||]
+ signum x = [|| signum $$x ||]
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Tuple (fst)
-import System.IO (IO)
import Text.Show (Show(..))
import qualified Data.Functor as Functor
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Tree as Tree
-import qualified Language.Haskell.TH as TH
-import qualified Language.Haskell.TH.Show as TH
-import qualified Language.Haskell.TH.Syntax as TH
import Symantic.Typed.Letable
-import qualified Symantic.Typed.Trans as Sym
-import qualified Symantic.Typed.Data as Sym
-import qualified Symantic.Typed.View as Sym
import Symantic.Parser.Grammar.Combinators
import qualified Symantic.Parser.Grammar.Production as Prod
try x = ViewGrammar $ Tree.Node ("try", "") [unViewGrammar x]
instance CombApplicable (ViewGrammar sN) where
_f <$> x = ViewGrammar $ Tree.Node ("<$>", "") [unViewGrammar x]
- pure a = ViewGrammar $ Tree.Node ("pure " <> TH.showCode (Sym.trans (Prod.prodCode a)), "") []
+ pure a = ViewGrammar $ Tree.Node ("pure " <> show (Prod.prodCode a), "") []
x <*> y = ViewGrammar $ Tree.Node ("<*>", "") [unViewGrammar x, unViewGrammar y]
x <* y = ViewGrammar $ Tree.Node ("<*", "") [unViewGrammar x, unViewGrammar y]
x *> y = ViewGrammar $ Tree.Node ("*>", "") [unViewGrammar x, unViewGrammar y]
import Symantic.Parser.Grammar.Combinators (Exception(..), Failure(..), SomeFailure(..), inputTokenProxy)
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
-import qualified Symantic.Parser.Grammar.Production as Prod
import qualified Language.Haskell.TH.HideName as TH
-import qualified Symantic.Typed.Data as Prod
import qualified Symantic.Typed.Lang as Prod
--import Debug.Trace
if checkedHorizon ctx >= 1
then unGen ok ctx0{checkedHorizon = checkedHorizon ctx - 1}
else let minHoriz =
- either (\err -> 0) id $
+ either (\_err -> 0) id $
minReads $ finalGenAnalysis ctx ok in
[||
if $$(moreInput ctx)
import Data.Eq (Eq(..))
import Data.Function ((.))
import Data.Kind (Type)
-import Data.Ord (Ord(..))
import Data.Set (Set)
-import Text.Show (Show(..), showParen, showString)
+import Text.Show (Show(..))
import qualified Language.Haskell.TH as TH
-import qualified Language.Haskell.TH.Show as TH
import Symantic.Parser.Grammar
import Symantic.Parser.Machine.Input
import qualified Symantic.Typed.Lang as Prod
-import qualified Symantic.Typed.Trans as Sym
import qualified Symantic.Typed.Data as Sym
-- * Type 'Splice'
type Splice = Sym.SomeData TH.CodeQ
-instance Show (Splice a) where
- showsPrec p = showParen (p >= 0) . showString . TH.showCode . Sym.trans
-
splice :: TH.CodeQ a -> Splice a
splice x = Sym.SomeData (Sym.Var x)
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
---{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
---{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-} -- For Abstractable (SomeData repr)
{-# LANGUAGE ViewPatterns #-}
module Symantic.Typed.Data where
-import Data.Kind
-import Type.Reflection
-import Data.Char (Char)
+import Data.Kind (Constraint, Type)
+import Type.Reflection (Typeable, (:~~:)(..), eqTypeRep, typeRep)
import Data.Bool (Bool)
import Data.Either (Either)
import Data.Maybe (Maybe)
-import Data.Functor.Identity (Identity(..))
-import Data.String (String)
-import Prelude (undefined)
-import Text.Show (Show(..))
import qualified Data.Eq as Eq
import qualified Data.Maybe as Maybe
import qualified Data.Function as Fun
-import Data.Coerce
import Symantic.Typed.Lang
import Symantic.Typed.Trans
import Data.Bool (Bool(..))
import Data.Either (Either(..))
import Data.Eq (Eq)
-import Data.Kind
import Data.Maybe (Maybe(..))
-import Prelude (undefined)
-import Text.Show (Show(..))
-import qualified Data.Eq as Eq
import qualified Data.Function as Fun
-import qualified Prelude
import Symantic.Typed.Trans
Liftable repr => Constantable c (Output 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)
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 Listable repr where
cons :: repr (a -> [a] -> [a])
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE QuantifiedConstraints #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ViewPatterns #-}
module Symantic.Typed.Optim where
-import Data.Kind
-import Type.Reflection
-import Data.Char (Char)
-import Data.Bool (Bool(..))
-import Data.Maybe (Maybe(..))
-import Data.Functor.Identity (Identity(..))
-import Data.String (String)
-import Prelude (undefined)
-import Text.Show (Show(..))
-import qualified Data.Eq as Eq
import qualified Data.Function as Fun
-
-import Symantic.Typed.Trans
import Symantic.Typed.Lang
import Symantic.Typed.Data
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- For Show (SomeData a)
module Symantic.Typed.View where
-{-
+
import Data.Int (Int)
-import Data.Semigroup (Semigroup(..))
import Data.String
-import Prelude (undefined)
import Text.Show
-import Type.Reflection (Typeable)
import qualified Data.Function as Fun
import qualified Prelude
ViewApp :: View (b -> a) -> View b -> View a
runView :: View a -> ViewEnv -> ShowS
-runView (View f) env = f env
-runView (ViewInfix _op name _infixName) env = showString name
+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..
instance IsString (View a) where
fromString s = View Fun.$ \_env -> showString s
instance Show (View a) where
- showsPrec p (View v) = v ViewEnv
+ 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)
instance Maybeable View where
nothing = "Nothing"
just = "Just"
--}
sourcephile / git / haskell / symantic-parser.git / commitdiff