From 01ce3d75986df7225d2e34011f57775d20fb77d8 Mon Sep 17 00:00:00 2001
From: Julien Moutinho <julm+symantic-parser@sourcephile.fr>
Date: Sat, 20 Jan 2024 00:06:12 +0100
Subject: [PATCH] impl: tweak viewing and writing
---
src/Symantic/Parser/Grammar/Production.hs | 16 +-
src/Symantic/Parser/Grammar/View.hs | 23 ++-
src/Symantic/Parser/Grammar/Write.hs | 236 +++++++++++-----------
src/Symantic/Parser/Machine/View.hs | 14 +-
4 files changed, 149 insertions(+), 140 deletions(-)
diff --git a/src/Symantic/Parser/Grammar/Production.hs b/src/Symantic/Parser/Grammar/Production.hs
index d726884..c86d278 100644
--- a/src/Symantic/Parser/Grammar/Production.hs
+++ b/src/Symantic/Parser/Grammar/Production.hs
@@ -33,6 +33,16 @@ data Production (vs :: [Type]) a where
--ProdN :: Production vs (a->b) -> Production (a ': vs) b
--ProdW :: Production vs b -> Production (a ': vs) b
+instance Show (Production '[] a) where
+ showsPrec p x = showsPrec p (normalOrderReduction (prodCode x))
+instance Show (SomeData TH.CodeQ a) where
+ -- The 'Derivable' constraint contained in 'SomeData'
+ -- is 'TH.CodeQ', hence 'Symantic.View' cannot be used here.
+ -- Fortunately 'TH.showCode' can be implemented.
+ showsPrec p = showString Fun.. TH.showCode p Fun.. derive
+
+
+
data Prod a = Prod
{ prodI :: SomeData Identity a
, prodQ :: SomeData TH.CodeQ a
@@ -109,12 +119,6 @@ prodCon name = do
(TH.unsafeCodeCoerce (return (TH.ConE $(TH.lift n)))) |]
_ -> error "[BUG]: impossible prodCon case"
-instance Show (SomeData TH.CodeQ a) where
- -- The 'Derivable' constraint contained in 'SomeData'
- -- is 'TH.CodeQ', hence 'Symantic.View' cannot be used here.
- -- Fortunately 'TH.showCode' can be implemented.
- showsPrec p = showString Fun.. TH.showCode p Fun.. derive
-
unProdE :: Production '[] a -> Prod a
unProdE t = case t of ProdE t' -> t'
diff --git a/src/Symantic/Parser/Grammar/View.hs b/src/Symantic/Parser/Grammar/View.hs
index 2f87a51..40d6a57 100644
--- a/src/Symantic/Parser/Grammar/View.hs
+++ b/src/Symantic/Parser/Grammar/View.hs
@@ -1,4 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE StandaloneDeriving #-}
module Symantic.Parser.Grammar.View where
import Data.Bool (Bool)
@@ -14,22 +16,24 @@ 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 Prelude (undefined)
+import Control.DeepSeq (NFData(..))
import Symantic.Semantics.SharingObserver
import Symantic.Semantics.Data (normalOrderReduction)
import Symantic.Parser.Grammar.Combinators
import Symantic.Parser.Grammar.SharingObserver
import qualified Symantic.Parser.Grammar.Production as Prod
+import qualified Language.Haskell.TH as TH
+import qualified Language.Haskell.TH.Syntax as TH
-- * Type 'ViewGrammar'
newtype ViewGrammar (showName::Bool) a = ViewGrammar { unViewGrammar :: Tree.Tree (String, String) }
+ deriving (NFData, TH.Lift)
viewGrammar :: ViewGrammar sN a -> ViewGrammar sN a
viewGrammar = id
-showProduction :: Prod.Production '[] a -> String
-showProduction p = showsPrec 10 (normalOrderReduction (Prod.prodCode p)) ""
-
instance Show (ViewGrammar sN a) where
show = List.unlines . draw . unViewGrammar
where
@@ -48,11 +52,10 @@ instance CombAlternable (ViewGrammar sN) where
("<|>" <> if exn == ExceptionFailure then "" else ("^"<>show exn), "")
[unViewGrammar x, unViewGrammar y]
throw exn = ViewGrammar $ Tree.Node ("throw "<>show exn, "") []
- failure _sf = ViewGrammar $ Tree.Node ("failure", "") []
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 "<>showProduction a, "") []
+ pure a = ViewGrammar $ Tree.Node ("pure "<>show 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]
@@ -90,10 +93,9 @@ instance CombMatchable (ViewGrammar sN) where
conditional a bs d = ViewGrammar $ Tree.Node ("conditional", "")
$ Tree.Node ("condition", "") [unViewGrammar a]
: Tree.Node ("default", "") [unViewGrammar d]
- : ((\(p,b) -> Tree.Node ("branch "<>showProduction p, "") [unViewGrammar b]) Functor.<$> bs)
+ : ((\(p,b) -> Tree.Node ("branch "<>show p, "") [unViewGrammar b]) Functor.<$> bs)
instance CombSatisfiable tok (ViewGrammar sN) where
- satisfyOrFail _fs p = ViewGrammar $ Tree.Node
- ("satisfy "<>showProduction p, "") []
+ satisfyOrFail p = ViewGrammar $ Tree.Node ("satisfy "<>show p, "") []
instance CombSelectable (ViewGrammar sN) where
branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
[ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
@@ -101,3 +103,8 @@ instance CombRegisterableUnscoped (ViewGrammar sN) where
newUnscoped r x y = ViewGrammar $ Tree.Node ("new "<>show r, "") [ unViewGrammar x, unViewGrammar y ]
getUnscoped r = ViewGrammar $ Tree.Node ("get "<>show r, "") [ ]
putUnscoped r x = ViewGrammar $ Tree.Node ("put "<>show r, "") [ unViewGrammar x ]
+instance CombRegisterable (ViewGrammar sN) where
+ new x f = undefined
+ get = undefined
+ put = undefined
+ -- FIXME
diff --git a/src/Symantic/Parser/Grammar/Write.hs b/src/Symantic/Parser/Grammar/Write.hs
index 44c6b78..9e8bdc0 100644
--- a/src/Symantic/Parser/Grammar/Write.hs
+++ b/src/Symantic/Parser/Grammar/Write.hs
@@ -1,9 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveLift #-}
module Symantic.Parser.Grammar.Write where
import Control.Monad (Monad(..))
import Data.Bool (Bool(..))
-import Data.Function (($))
+import Data.Function (($), (.))
import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
@@ -15,163 +16,160 @@ import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
+import Control.DeepSeq (NFData(..))
+import qualified Language.Haskell.TH as TH
+import qualified Language.Haskell.TH.Syntax as TH
+import Prelude (undefined)
+import Debug.Trace
import Symantic.Semantics.SharingObserver
import Symantic.Semantics.Viewer.Fixity
import Symantic.Parser.Grammar.Combinators
+import Symantic.Parser.Grammar.SharingObserver
-- * Type 'WriteGrammar'
newtype WriteGrammar (showName::Bool) a = WriteGrammar { unWriteGrammar ::
- WriteGrammarInh -> Maybe TLB.Builder }
+ WriteGrammarEnv -> Maybe TLB.Builder }
+ deriving (NFData)
instance IsString (WriteGrammar sN a) where
- fromString s = WriteGrammar $ \_inh ->
+ fromString s = WriteGrammar $ \_env ->
if List.null s then Nothing
else Just (fromString s)
--- ** Type 'WriteGrammarInh'
-data WriteGrammarInh
- = WriteGrammarInh
- { writeGrammarInh_indent :: TLB.Builder
- , writeGrammarInh_op :: (Infix, Side)
- , writeGrammarInh_pair :: Pair
- }
-
-emptyWriteGrammarInh :: WriteGrammarInh
-emptyWriteGrammarInh = WriteGrammarInh
- { writeGrammarInh_indent = "\n"
- , writeGrammarInh_op = (infixN0, SideL)
- , writeGrammarInh_pair = pairParen
- }
+-- ** Type 'WriteGrammarEnv'
+data WriteGrammarEnv
+ = WriteGrammarEnv
+ { writeGrammarEnvIndent :: TLB.Builder
+ , writeGrammarEnvOpFixity :: Infix
+ , writeGrammarEnvOpSide :: Side
+ , writeGrammarEnvPair :: Pair
+ } deriving (Show)
writeGrammar :: WriteGrammar sN a -> TL.Text
writeGrammar (WriteGrammar go) =
TLB.toLazyText $ fromMaybe "" $
- go emptyWriteGrammarInh
+ go WriteGrammarEnv
+ { writeGrammarEnvIndent = "\n"
+ , writeGrammarEnvOpFixity = infixN0
+ , writeGrammarEnvOpSide = SideL
+ , writeGrammarEnvPair = pairParen
+ }
+
+instance Show (WriteGrammar sN a) where
+ show = TL.unpack . writeGrammar
-pairWriteGrammarInh ::
- Semigroup s => IsString s =>
- WriteGrammarInh -> Infix -> Maybe s -> Maybe s
-pairWriteGrammarInh inh op s =
- if isPairNeeded (writeGrammarInh_op inh) op
- then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
- else s
- where (o,c) = writeGrammarInh_pair inh
+writeGrammarPair ::
+ Infix -> (WriteGrammarEnv -> Maybe TLB.Builder) -> WriteGrammar sN a
+writeGrammarPair op wg = WriteGrammar $ \env ->
+ let newEnv = env{writeGrammarEnvOpFixity=op, writeGrammarEnvOpSide=SideL} in
+ if isPairNeeded (writeGrammarEnvOpFixity env, writeGrammarEnvOpSide env) op
+ then
+ let (o,c) = writeGrammarEnvPair env in
+ Just (fromString o)<> wg newEnv <> Just (fromString c)
+ else wg newEnv
instance CombAlternable (WriteGrammar sN) where
- alt exn x y = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- unWriteGrammar x inh
- { writeGrammarInh_op = (op, SideL)
- , writeGrammarInh_pair = pairParen
+ alt exn x y = writeGrammarPair (infixB SideL 3) $ \env ->
+ unWriteGrammar x env
+ { writeGrammarEnvOpSide = SideL
+ , writeGrammarEnvPair = pairParen
} <>
Just (" |^"<>fromString (show exn)<>" ") <>
- unWriteGrammar y inh
- { writeGrammarInh_op = (op, SideR)
- , writeGrammarInh_pair = pairParen
+ unWriteGrammar y env
+ { writeGrammarEnvOpSide = SideR
+ , writeGrammarEnvPair = pairParen
}
- where op = infixB SideL 3
- throw exn = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just ("throw "<>fromString (show exn))
- where
- op = infixN 9
- failure _sf = "failure"
+ throw exn = writeGrammarPair (infixN 9) $ \env ->
+ Just ("throw "<>fromString (show exn))
empty = "empty"
- try x = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just "try " <> unWriteGrammar x inh
- where
- op = infixN 9
+ try x = writeGrammarPair (infixN 9) $ \env ->
+ Just "try " <> unWriteGrammar x env
instance CombApplicable (WriteGrammar sN) where
pure _ = WriteGrammar $ return Nothing{-TODO: print?-}
-- pure _ = "pure"
- WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
- let inh' side = inh
- { writeGrammarInh_op = (op, side)
- , writeGrammarInh_pair = pairParen
- } in
- case x (inh' SideL) of
- Nothing -> y (inh' SideR)
- Just xt ->
- case y (inh' SideR) of
- Nothing -> Just xt
- Just yt ->
- pairWriteGrammarInh inh op $
- Just $ xt <> ", " <> yt
- where
- op = infixN 1
+ x <*> y = writeGrammarPair (infixB SideL 4) $ \env ->
+ let env' side = env { writeGrammarEnvPair = pairParen } in
+ case unWriteGrammar x (env' SideL) of
+ Nothing -> unWriteGrammar y (env' SideR)
+ Just xText ->
+ case unWriteGrammar y (env' SideR) of
+ Nothing -> Just xText
+ Just _yText ->
+ unWriteGrammar x env{writeGrammarEnvOpSide = SideL} <>
+ Just " " <>
+ unWriteGrammar y env{writeGrammarEnvOpSide = SideR}
instance CombFoldable (WriteGrammar sN) where
- chainPre f x = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just "chainPre " <>
- unWriteGrammar f inh <> Just " " <>
- unWriteGrammar x inh
- where op = infixN 9
- chainPost f x = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just "chainPost " <>
- unWriteGrammar f inh <> Just " " <>
- unWriteGrammar x inh
- where op = infixN 9
+ chainPre f x = writeGrammarPair (infixN 9) $ \env ->
+ Just "chainPre " <>
+ unWriteGrammar f env <> Just " " <>
+ unWriteGrammar x env
+ chainPost f x = writeGrammarPair (infixN 9) $ \env ->
+ Just "chainPost " <>
+ unWriteGrammar f env <> Just " " <>
+ unWriteGrammar x env
instance
( Show letName
, HideName letName
, HideableName sN
) => Referenceable letName (WriteGrammar sN) where
- ref isRec name = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just (if isRec then "rec " else "ref ") <>
- Just (fromString (show (hideableName @sN name)))
- where
- op = infixN 9
+ ref isRec name = writeGrammarPair (infixN 9) $ \env ->
+ Just (if isRec then "rec " else "ref ") <>
+ Just (fromString (show (hideableName @sN name)))
instance
( Show letName
, HideName letName
, HideableName sN
) => Letsable letName (WriteGrammar sN) where
- lets defs x = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just "let "
- <> HM.foldMapWithKey
- (\name (SomeLet val) ->
- Just (fromString (show (hideableName @sN name)))
- <> unWriteGrammar val inh)
- defs
- <> unWriteGrammar x inh
- where
- op = infixN 9
+ lets defs x = writeGrammarPair (infixN 9) $ \env ->
+ Just "let "
+ <> HM.foldMapWithKey
+ (\name (SomeLet val) ->
+ Just (fromString (show (hideableName @sN name)))
+ <> unWriteGrammar val env)
+ defs
+ <> unWriteGrammar x env
instance CombLookable (WriteGrammar sN) where
- look x = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just "look " <> unWriteGrammar x inh
- where op = infixN 9
- negLook x = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just "negLook " <> unWriteGrammar x inh
- where op = infixN 9
+ look x = writeGrammarPair (infixN 9) $ \env ->
+ Just "look " <> unWriteGrammar x env
+ negLook x = writeGrammarPair (infixN 9) $ \env ->
+ Just "negLook " <> unWriteGrammar x env
eof = "eof"
instance CombMatchable (WriteGrammar sN) where
- conditional a bs d = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just "conditional " <>
- unWriteGrammar a inh <>
- unWriteGrammar d inh <>
- Just " [" <>
- Just (mconcat (List.intersperse ", " $
- catMaybes $ (Functor.<$> bs) $ \(p{-TODO: print?-}, b) ->
- unWriteGrammar b inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
- Just "] "
- where
- op = infixN 9
+ conditional a bs d = writeGrammarPair (infixN 9) $ \env ->
+ Just "conditional " <>
+ unWriteGrammar a env <>
+ unWriteGrammar d env <>
+ Just " [" <>
+ Just (mconcat (List.intersperse ", " $
+ catMaybes $ (Functor.<$> bs) $ \(p{-TODO: print?-}, b) ->
+ unWriteGrammar b env
+ { writeGrammarEnvOpFixity = infixN 0
+ , writeGrammarEnvOpSide = SideL
+ })) <>
+ Just "] "
instance CombSatisfiable tok (WriteGrammar sN) where
- satisfyOrFail _fs _f = "satisfy"
+ satisfyOrFail p = writeGrammarPair (infixN 9) $ \env ->
+ Just "satisfy " <>
+ Just (fromString (showsPrec 10 p ""))
instance CombSelectable (WriteGrammar sN) where
- branch lr l r = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just "branch " <>
- unWriteGrammar lr inh <> Just " " <>
- unWriteGrammar l inh <> Just " " <>
- unWriteGrammar r inh
- where
- op = infixN 9
+ branch lr l r = writeGrammarPair (infixN 9) $ \env ->
+ Just "branch " <>
+ unWriteGrammar lr env <> Just " " <>
+ unWriteGrammar l env <> Just " " <>
+ unWriteGrammar r env
+instance CombRegisterableUnscoped (WriteGrammar sN) where
+ newUnscoped r x y = writeGrammarPair (infixN 9) $ \env ->
+ Just "newUnscoped " <> Just (fromString (show r)) <>
+ unWriteGrammar x env <> Just " " <>
+ unWriteGrammar y env
+ getUnscoped r = writeGrammarPair (infixN 9) $ \env ->
+ Just "getUnscoped " <> Just (fromString (show r))
+ putUnscoped r x = writeGrammarPair (infixN 9) $ \env ->
+ Just "putUnscoped " <> Just (fromString (show r)) <>
+ unWriteGrammar x env
+instance CombRegisterable (WriteGrammar sN) where
+ new x f = undefined
+ get = undefined
+ put = undefined
+ -- FIXME
diff --git a/src/Symantic/Parser/Machine/View.hs b/src/Symantic/Parser/Machine/View.hs
index b0cd26b..d305735 100644
--- a/src/Symantic/Parser/Machine/View.hs
+++ b/src/Symantic/Parser/Machine/View.hs
@@ -127,7 +127,7 @@ instance
} where gen = raise exn
fail fs = ViewMachine
{ unViewMachine = \lm next ->
- viewInstrCmd @sN (Right gen) lm ("fail "<>show (Set.toList fs), "") [] : next
+ viewInstrCmd @sN (Right gen) lm ("fail "{-<>show fs-}, "") [] : next
, viewGen = gen
} where gen = fail fs
commit exn k = ViewMachine
@@ -229,23 +229,23 @@ instance
( HideableName sN
, InstrReadable tok Gen
) => InstrReadable tok (ViewMachine sN) where
- read es p k = ViewMachine
+ read p k = ViewMachine
{ unViewMachine = \lm next ->
viewInstrCmd @sN (Right gen) lm ("read "<>showSplice p, "") [] :
unViewMachine k lm next
, viewGen = gen
- } where gen = read es p (viewGen k)
+ } where gen = read p (viewGen k)
instance
HideableName sN =>
InstrIterable (ViewMachine sN) where
- iter jumpName@(LetName n) ok ko = ViewMachine
+ iter jumpName@(LetName n) loop done = ViewMachine
{ unViewMachine = \lm next ->
viewInstrCmd @sN (Right gen) lm ("iter", " "<>show (hideableName @sN n))
- [ viewInstrArg "ok" (unViewMachine ok lm [])
- , viewInstrArg "ko" (unViewMachine ko lm [])
+ [ viewInstrArg "loop" (unViewMachine loop lm [])
+ , viewInstrArg "done" (unViewMachine done lm [])
] : next
, viewGen = gen
- } where gen = iter jumpName (viewGen ok) (viewGen ko)
+ } where gen = iter jumpName (viewGen loop) (viewGen done)
instance
HideableName sN =>
InstrRegisterable (ViewMachine sN) where
--
2.47.2