{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DeriveAnyClass #-} -- For NFData instances
+{-# LANGUAGE DeriveGeneric #-} -- For NFData instances
{-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp)
{-# LANGUAGE ConstraintKinds #-} -- For Dict
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Machine.Generate where
+import Control.DeepSeq (NFData(..))
import Control.Monad (Monad(..))
import Data.Bool (Bool)
import Data.Char (Char)
import Data.Either (Either(..), either)
+import Data.Foldable (foldMap', toList, null)
import Data.Function (($), (.), id, const, on)
import Data.Functor (Functor, (<$>), (<$))
-import Data.Foldable (foldMap', toList, null)
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map (Map)
import Data.Maybe (Maybe(..))
-import Data.Eq (Eq(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Traversable (Traversable(..))
import Data.Typeable (Typeable)
+import Data.Word (Word8)
+import GHC.Generics (Generic)
+import GHC.Show (showCommaSpace)
import Language.Haskell.TH (CodeQ)
import Prelude ((+), (-), error)
-import Text.Show (Show(..))
--- import qualified Control.Monad.Trans.State.Strict as MT
+import Text.Show (Show(..), showParen, showString)
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Internal as Map_
-import qualified Data.Set.Internal as Set_
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
+import qualified Data.Set.Internal as Set_
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-import Symantic.Univariant.Letable
-import Symantic.Univariant.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.Parser.Haskell as H
+import qualified Symantic.Typed.Lang as Prod
+import qualified Symantic.Typed.Optimize as Prod
--import Debug.Trace
-genCode :: TermInstr a -> CodeQ a
-genCode = trans
+-- | Convenient utility to generate some final 'TH.CodeQ'.
+genCode :: Splice a -> CodeQ a
+genCode = derive . Prod.normalOrderReduction
-- * Type 'Gen'
-- | Generate the 'CodeQ' parsing the input.
-- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
-- parsing the given 'input' according to the given 'Machine'.
generateCode ::
- Ord (InputToken inp) =>
+ {-
+ Eq (InputToken inp) =>
+ NFData (InputToken inp) =>
Show (InputToken inp) =>
Typeable (InputToken inp) =>
TH.Lift (InputToken inp) =>
+ -}
-- InputToken inp ~ Char =>
- Input inp =>
+ Inputable inp =>
Show (Cursor inp) =>
Gen inp '[] a ->
CodeQ (inp -> Either (ParsingError inp) a)
finalRet = \_farInp _farExp v _inp -> Right v
finalRaise :: forall b. (Catcher inp b)
= \ !exn _failInp !farInp !farExp ->
- Left ParsingErrorStandard
+ Left ParsingError
{ parsingErrorOffset = offset farInp
, parsingErrorException = exn
, parsingErrorUnexpected =
}
)
||]
- where
-- ** Type 'ParsingError'
data ParsingError inp
- = ParsingErrorStandard
+ = ParsingError
{ parsingErrorOffset :: Offset
, parsingErrorException :: Exception
- -- | Note that if an 'FailureHorizon' greater than 1
+ -- | Note: if a 'FailureHorizon' greater than 1
-- is amongst the 'parsingErrorExpecting'
- -- then this is only the 'InputToken'
+ -- then 'parsingErrorUnexpected' is only the 'InputToken'
-- at the begining of the expected 'Horizon'.
, parsingErrorUnexpected :: Maybe (InputToken inp)
, parsingErrorExpecting :: Set SomeFailure
- }
-deriving instance Show (InputToken inp) => Show (ParsingError inp)
+ } deriving (Generic)
+deriving instance NFData (InputToken inp) => NFData (ParsingError inp)
+--deriving instance Show (InputToken inp) => Show (ParsingError inp)
+instance Show (InputToken inp) => Show (ParsingError inp) where
+ showsPrec p ParsingError{..} =
+ showParen (p >= 11) $
+ showString "ParsingErrorStandard {" .
+ showString "parsingErrorOffset = " .
+ showsPrec 0 parsingErrorOffset .
+ showCommaSpace .
+ showString "parsingErrorException = " .
+ showsPrec 0 parsingErrorException .
+ showCommaSpace .
+ showString "parsingErrorUnexpected = " .
+ showsPrec 0 parsingErrorUnexpected .
+ showCommaSpace .
+ showString "parsingErrorExpecting = fromList " .
+ showsPrec 0 (
+ -- Sort on the string representation
+ -- because the 'Ord' of the 'SomeFailure'
+ -- is based upon hashes ('typeRepFingerprint')
+ -- depending on packages' ABI and whether
+ -- cabal-install's setup is --inplace or not,
+ -- and that would be too unstable for golden tests.
+ List.sortBy (compare `on` show) $
+ Set.toList parsingErrorExpecting
+ ) .
+ showString "}"
-- ** Type 'ErrorLabel'
type ErrorLabel = String
-- | This is an inherited (top-down) context
-- only present at compile-time, to build TemplateHaskell splices.
data GenCtx inp vs a =
- ( TH.Lift (InputToken inp)
- , Cursorable (Cursor inp)
+ ( Cursorable (Cursor inp)
+ {-
+ , TH.Lift (InputToken inp)
, Show (InputToken inp)
+ , Eq (InputToken inp)
+ , Typeable (InputToken inp)
+ , NFData (InputToken inp)
+ -}
) => GenCtx
{ valueStack :: ValueStack vs
, catchStackByLabel :: Map Exception (NonEmpty (CodeQ (Catcher inp a)))
data ValueStack vs where
ValueStackEmpty :: ValueStack '[]
ValueStackCons ::
- { valueStackHead :: TermInstr v
+ { valueStackHead :: Splice v
, valueStackTail :: ValueStack vs
} -> ValueStack (v ': vs)
{ unGen = \ctx -> {-trace "unGen.lift2Value" $-} unGen k ctx
{ valueStack =
let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
- ValueStackCons (f H.:@ x H.:@ y) vs
+ ValueStackCons (f Prod..@ x Prod..@ y) vs
}
}
swapValue k = k
let ValueStackCons v vs = valueStack ctx in
[||
case $$(genCode v) of
- Left x -> $$(unGen kx ctx{ valueStack = ValueStackCons (H.Term [||x||]) vs })
- Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (H.Term [||y||]) vs })
+ Left x -> $$(unGen kx ctx{ valueStack = ValueStackCons (splice [||x||]) vs })
+ Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (splice [||y||]) vs })
||]
}
choicesBranch fs ks kd = Gen
}
where
go ctx x (f:fs') (k:ks') = [||
- if $$(genCode (H.optimizeTerm (f H.:@ x)))
+ if $$(genCode (f Prod..@ x))
then
let _ = "choicesBranch.then" in
$$({-trace "unGen.choicesBranch.k" $-} unGen k ctx)
}
, unGen = \ctx@GenCtx{} -> {-trace ("unGen.fail: "<>show exn) $-}
if null fs
- then [||
+ then [|| -- Raise without updating the farthest error.
$$(raiseException ctx ExceptionFailure)
ExceptionFailure
{-failInp-}$$(input ctx)
-- as they were when entering 'catch',
-- they will be available to 'loadInput', if any.
{ valueStack =
- ValueStackCons (H.Term (input ctx)) $
- --ValueStackCons (H.Term [||exn||]) $
+ ValueStackCons (splice (input ctx)) $
+ --ValueStackCons (Prod.var [||exn||]) $
valueStack ctx
, horizonStack =
checkedHorizon ctx : horizonStack ctx
}
) ||]
}
-
--- ** Type 'Catcher'
-type Catcher inp a =
- Exception ->
- {-failInp-}Cursor inp ->
- {-farInp-}Cursor inp ->
- {-farExp-}(Set SomeFailure) ->
- Either (ParsingError inp) a
instance InstrInputable Gen where
pushInput k = k
{ unGen = \ctx ->
{-trace "unGen.pushInput" $-}
unGen k ctx
- { valueStack = H.Term (input ctx) `ValueStackCons` valueStack ctx
+ { valueStack = splice (input ctx) `ValueStackCons` valueStack ctx
, horizonStack = checkedHorizon ctx : horizonStack ctx
}
}
let _ = $$(liftTypedString $ "suspend") in
\farInp farExp v !inp ->
$$({-trace "unGen.generateSuspend" $-} unGen k ctx
- { valueStack = ValueStackCons ({-trace "unGen.generateSuspend.value" $-} H.Term [||v||]) (valueStack ctx)
+ { valueStack = ValueStackCons ({-trace "unGen.generateSuspend.value" $-} splice [||v||]) (valueStack ctx)
, input = [||inp||]
, farthestInput = [||farInp||]
, farthestExpecting = [||farExp||]
$$k
$$(farthestInput ctx)
$$(farthestExpecting ctx)
- (let _ = "resume.genCode" in $$({-trace "unGen.generateResume.genCode" $-} genCode $ H.optimizeTerm $
- valueStackHead $ valueStack ctx))
+ (let _ = "resume.genCode" in $$({-trace "unGen.generateResume.genCode" $-}
+ genCode $ valueStackHead $ valueStack ctx))
$$(input ctx)
||]
}
+-- ** Type 'Catcher'
+type Catcher inp a =
+ Exception ->
+ {-failInp-}Cursor inp ->
+ {-farInp-}Cursor inp ->
+ {-farExp-}(Set SomeFailure) ->
+ Either (ParsingError inp) a
+
instance InstrJoinable Gen where
defJoin (LetName n) sub k = k
{ unGen =
-- Called by 'generateResume'.
\farInp farExp v !inp ->
$$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
- { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
+ { valueStack = ValueStackCons (splice [||v||]) (valueStack ctx)
, input = [||inp||]
, farthestInput = [||farInp||]
, farthestExpecting = [||farExp||]
}
instance InstrReadable Char Gen where
read fs p = checkHorizon . checkToken fs p
+instance InstrReadable Word8 Gen where
+ read fs p = checkHorizon . checkToken fs p
checkHorizon ::
forall inp vs a.
- Eq (InputToken inp) =>
+ -- Those constraints are not used anyway
+ -- because (TH.Lift SomeFailure) uses 'inputTokenProxy'.
Ord (InputToken inp) =>
- Typeable (InputToken inp) =>
+ Show (InputToken inp) =>
TH.Lift (InputToken inp) =>
+ NFData (InputToken inp) =>
+ Typeable (InputToken inp) =>
{-ok-}Gen inp vs a ->
Gen inp vs a
checkHorizon ok = ok
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)
finalGenAnalysisByLet ctx
checkToken ::
- Ord (InputToken inp) =>
- TH.Lift (InputToken inp) =>
Set SomeFailure ->
- {-predicate-}TermInstr (InputToken inp -> Bool) ->
+ {-predicate-}Splice (InputToken inp -> Bool) ->
{-ok-}Gen inp (InputToken inp ': vs) a ->
Gen inp vs a
checkToken fs p ok = ok
{ unGen = \ctx -> {-trace "unGen.read" $-} [||
let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
- if $$(genCode p) c
- then $$(unGen ok ctx
- { valueStack = ValueStackCons (H.Term [||c||]) (valueStack ctx)
- , input = [||cs||]
- })
- else let _ = "checkToken.else" in
- $$(unGen (fail fs) ctx)
- ||]
+ $$(genCode $
+ Prod.ifThenElse
+ (p Prod..@ splice [||c||])
+ (splice $ unGen ok ctx
+ { valueStack = ValueStackCons (splice [||c||]) (valueStack ctx)
+ , input = [||cs||]
+ })
+ (splice [||
+ let _ = "checkToken.else" in
+ $$(unGen (fail fs) ctx)
+ ||])
+ )||]
}
sourcephile / git / haskell / symantic-parser.git / blobdiff