+{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE UndecidableInstances #-} -- For ShowLetName
+{-# LANGUAGE UndecidableInstances #-} -- For HideableName
module Symantic.Parser.Machine.View where
import Data.Bool (Bool(..))
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Tree as Tree
+import Language.Haskell.TH.HideName
import qualified Language.Haskell.TH.Syntax as TH
import Prelude (error)
+import Symantic.Semantics.Data (normalOrderReduction)
import Symantic.Parser.Grammar.Combinators (UnscopedRegister(..))
-import Symantic.Parser.Grammar.ObserveSharing
+import Symantic.Parser.Grammar.SharingObserver
import Symantic.Parser.Machine.Instructions
-import Symantic.ObserveSharing (SomeLet(..))
import Symantic.Parser.Machine.Generate
-- * Type 'ViewMachine'
-- ^ Provide 'GenAnalysis', which is important for debugging
-- and improving golden tests, see 'viewInstrCmd'.
, unViewMachine ::
- CallTrace ->
- LetRecs TH.Name GenAnalysis -> -- Output of 'runOpenRecs'.
+ LetRecs TH.Name GenAnalysis -> -- Output of 'mutualFix'.
Tree.Forest (String, String) ->
Tree.Forest (String, String)
}
-viewMachine ::
- ViewMachine sN inp vs a ->
- ViewMachine sN inp vs a
+viewMachine :: ViewMachine sN inp vs a -> ViewMachine sN inp vs a
viewMachine = id
+showSplice :: Splice a -> String
+showSplice p = showsPrec 10 (normalOrderReduction p) ""
+
-- | Helper to view a command.
viewInstrCmd ::
+ forall (sN::Bool) inp vs a.
+ HideableName sN =>
Either TH.Name (Gen inp vs a) ->
- CallTrace ->
LetRecs TH.Name GenAnalysis ->
(String, String) -> Tree.Forest (String, String) -> Tree.Tree (String, String)
-viewInstrCmd gen ct lm (n, no) = Tree.Node $ (n
+viewInstrCmd gen finalByLet (cmd, no) = Tree.Node $ (cmd
<> "\nminReads="<>showsPrec 11 (minReads ga) ""
- <> "\nmayRaise="<>showsPrec 11 (Map.keys (mayRaise ga)) ""
+ <> "\nmayRaise="<>show (Map.keys (mayRaise ga))
+ <> "\nalwaysRaise="<>show (Set.toList (alwaysRaise ga))
+ <> "\nfreeRegs="<>show (hideableName @sN (Set.toList (freeRegs ga)))
, no)
where
ga = case gen of
- Right r -> (\f -> f ct) $ genAnalysis r $ (\f _ct -> f) <$> lm
- Left l -> HM.findWithDefault (error (show (l, HM.keys lm))) l lm
+ Right a -> genAnalysis a finalByLet
+ Left n -> HM.findWithDefault (error (show (n, HM.keys finalByLet))) n finalByLet
-- | Helper to view an argument.
viewInstrArg :: String -> Tree.Forest (String, String) -> Tree.Tree (String, String)
instance Show (ViewMachine sN inp vs a) where
show vm = List.unlines $ drawTrees $
- unViewMachine vm [] (runOpenRecs (genAnalysisByLet (viewGen vm))) []
+ unViewMachine vm (mutualFix (genAnalysisByLet (viewGen vm))) []
where
draw :: Tree.Tree (String, String) -> [String]
draw (Tree.Node (x, n) ts0) =
drawTrees (t:ts) = draw t <> drawTrees ts
shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)
-instance InstrValuable (ViewMachine sN) where
+instance
+ HideableName sN =>
+ InstrComment (ViewMachine sN) where
+ comment msg k = ViewMachine
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("comment "<>show msg, "") [] :
+ unViewMachine k lm next
+ , viewGen = gen
+ } where gen = comment msg (viewGen k)
+instance
+ HideableName sN =>
+ InstrValuable (ViewMachine sN) where
pushValue a k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("pushValue "<>showsPrec 10 a "", "") [] :
- unViewMachine k ct lm next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("pushValue "<>showSplice a, "") [] :
+ unViewMachine k lm next
, viewGen = gen
} where gen = pushValue a (viewGen k)
popValue k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("popValue", "") [] :
- unViewMachine k ct lm next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("popValue", "") [] :
+ unViewMachine k lm next
, viewGen = gen
} where gen = popValue (viewGen k)
lift2Value f k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("lift2Value "<>showsPrec 10 f "", "") [] :
- unViewMachine k ct lm next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("lift2Value "<>showSplice f, "") [] :
+ unViewMachine k lm next
, viewGen = gen
} where gen = lift2Value f (viewGen k)
swapValue k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("swapValue", "") [] :
- unViewMachine k ct lm next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("swapValue", "") [] :
+ unViewMachine k lm next
, viewGen = gen
} where gen = swapValue (viewGen k)
-instance InstrExceptionable (ViewMachine sN) where
+instance
+ HideableName sN =>
+ InstrExceptionable (ViewMachine sN) where
raise exn = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("raise "<>show exn, "") [] : next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("raise "<>show exn, "") [] : next
, viewGen = gen
} where gen = raise exn
- fail flr = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("fail "<>show (Set.toList flr), "") [] : next
+ fail fs = ViewMachine
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("fail "<>show (Set.toList fs), "") [] : next
, viewGen = gen
- } where gen = fail flr
+ } where gen = fail fs
commit exn k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("commit "<>show exn, "") [] :
- unViewMachine k ct lm next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("commit "<>show exn, "") [] :
+ unViewMachine k lm next
, viewGen = gen
} where gen = commit exn (viewGen k)
catch exn ok ko = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("catch "<>show exn, "")
- [ viewInstrArg "ok" (unViewMachine ok ct lm [])
- , viewInstrArg "ko" (unViewMachine ko ct lm [])
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("catch "<>show exn, "")
+ [ viewInstrArg "catchScope" (unViewMachine ok lm [])
+ , viewInstrArg ("onException "<>show exn) (unViewMachine ko lm [])
] : next
, viewGen = gen
} where gen = catch exn (viewGen ok) (viewGen ko)
-instance InstrBranchable (ViewMachine sN) where
+instance
+ HideableName sN =>
+ InstrBranchable (ViewMachine sN) where
caseBranch l r = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("case", "")
- [ viewInstrArg "left" (unViewMachine l ct lm [])
- , viewInstrArg "right" (unViewMachine r ct lm [])
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("case", "")
+ [ viewInstrArg "left" (unViewMachine l lm [])
+ , viewInstrArg "right" (unViewMachine r lm [])
] : next
, viewGen = gen
} where gen = caseBranch (viewGen l) (viewGen r)
choicesBranch bs d = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("choicesBranch", "") (
- ((\(p, b) -> viewInstrArg ("branch "<>showsPrec 10 p "") $
- unViewMachine b ct lm []) <$> bs) <>
- [ viewInstrArg "default" (unViewMachine d ct lm []) ]
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("choicesBranch", "") (
+ ((\(p, b) -> viewInstrArg ("branch "<>showSplice p) $
+ unViewMachine b lm []) <$> bs) <>
+ [ viewInstrArg "default" (unViewMachine d lm []) ]
) : next
, viewGen = gen
} where gen = choicesBranch ((viewGen <$>) <$> bs) (viewGen d)
instance
- ShowLetName sN TH.Name =>
+ HideableName sN =>
InstrCallable (ViewMachine sN) where
defLet defs k = ViewMachine
- { unViewMachine = \ct lm next ->
- (<> unViewMachine k ct lm next) $
+ { unViewMachine = \lm next ->
+ (<> unViewMachine k lm next) $
List.sortBy (compare `on` (((fst <$>) <$>) . Tree.levels)) $
((\(n, SomeLet sub) ->
- viewInstrCmd (Left n) ct lm
- ("let", " "<>showLetName @sN n)
- (unViewMachine sub ct lm []))
+ viewInstrCmd @sN (Left n) lm
+ ("let", " "<>show (hideableName @sN n))
+ (unViewMachine sub lm []))
<$> HM.toList defs)
, viewGen = gen
} where gen = defLet ((\(SomeLet x) -> SomeLet (viewGen x)) <$> defs) (viewGen k)
- jump ln@(LetName n) = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("jump", " "<>showLetName @sN n) [] : next
+ jump isRec ln@(LetName n) = ViewMachine
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("jump", " "<>show (hideableName @sN n)) [] : next
, viewGen = gen
- } where gen = jump ln
- call ln@(LetName n) k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("call", " "<>showLetName @sN n) [] :
- unViewMachine k (n:ct) lm next
+ } where gen = jump isRec ln
+ call isRec ln@(LetName n) k = ViewMachine
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("call", " "<>show (hideableName @sN n)) [] :
+ unViewMachine k lm next
, viewGen = gen
- } where gen = call ln (viewGen k)
+ } where gen = call isRec ln (viewGen k)
ret = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("ret", "") [] : next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("ret", "") [] : next
, viewGen = gen
} where gen = ret
instance
- ShowLetName sN TH.Name =>
+ HideableName sN =>
InstrJoinable (ViewMachine sN) where
- defJoin ln@(LetName n) j k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Left n) ct lm
- ("join", " "<>showLetName @sN n)
- (unViewMachine j ct lm []) :
- unViewMachine k (n:ct) lm next
- , viewGen = gen
- } where gen = defJoin ln (viewGen j) (viewGen k)
+ defJoin ln@(LetName n) sub k = ViewMachine
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Left n) lm
+ ("join", " "<>show (hideableName @sN n))
+ (unViewMachine sub lm []) :
+ unViewMachine k lm next
+ , viewGen = gen
+ } where gen = defJoin ln (viewGen sub) (viewGen k)
refJoin ln@(LetName n) = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("refJoin", " "<>showLetName @sN n) [] : next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("refJoin", " "<>show (hideableName @sN n)) [] : next
, viewGen = gen
} where gen = refJoin ln
-instance InstrInputable (ViewMachine sN) where
- pushInput k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("pushInput", "") [] :
- unViewMachine k ct lm next
+instance
+ HideableName sN =>
+ InstrInputable (ViewMachine sN) where
+ saveInput k = ViewMachine
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("saveInput", "") [] :
+ unViewMachine k lm next
, viewGen = gen
- } where gen = pushInput (viewGen k)
+ } where gen = saveInput (viewGen k)
loadInput k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("loadInput", "") [] :
- unViewMachine k ct lm next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("loadInput", "") [] :
+ unViewMachine k lm next
, viewGen = gen
} where gen = loadInput (viewGen k)
instance
- InstrReadable tok Gen =>
- InstrReadable tok (ViewMachine sN) where
+ ( HideableName sN
+ , InstrReadable tok Gen
+ ) => InstrReadable tok (ViewMachine sN) where
read es p k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("read "<>showsPrec 10 p "", "") [] :
- unViewMachine k ct lm next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("read "<>showSplice p, "") [] :
+ unViewMachine k lm next
, viewGen = gen
} where gen = read es p (viewGen k)
instance
- ShowLetName sN TH.Name =>
+ HideableName sN =>
InstrIterable (ViewMachine sN) where
iter jumpName@(LetName n) ok ko = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("iter", " "<>showLetName @sN n)
- [ viewInstrArg "ok" (unViewMachine ok ct lm [])
- , viewInstrArg "ko" (unViewMachine ko ct lm [])
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("iter", " "<>show (hideableName @sN n))
+ [ viewInstrArg "ok" (unViewMachine ok lm [])
+ , viewInstrArg "ko" (unViewMachine ko lm [])
] : next
, viewGen = gen
} where gen = iter jumpName (viewGen ok) (viewGen ko)
instance
- ShowLetName sN TH.Name =>
+ HideableName sN =>
InstrRegisterable (ViewMachine sN) where
newRegister reg@(UnscopedRegister r) k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("newRegister", " "<>showLetName @sN r) [] :
- unViewMachine k ct lm next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("newRegister", " "<>show (hideableName @sN r)) [] :
+ unViewMachine k lm next
, viewGen = gen
} where gen = newRegister reg (viewGen k)
readRegister reg@(UnscopedRegister r) k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("readRegister", " "<>showLetName @sN r) [] :
- unViewMachine k ct lm next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("readRegister", " "<>show (hideableName @sN r)) [] :
+ unViewMachine k lm next
, viewGen = gen
} where gen = readRegister reg (viewGen k)
writeRegister reg@(UnscopedRegister r) k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("writeRegister", " "<>showLetName @sN r) [] :
- unViewMachine k ct lm next
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("writeRegister", " "<>show (hideableName @sN r)) [] :
+ unViewMachine k lm next
, viewGen = gen
} where gen = writeRegister reg (viewGen k)
sourcephile / git / haskell / symantic-parser.git / blobdiff