+{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE UndecidableInstances #-} -- For ShowLetName
+{-# LANGUAGE UndecidableInstances #-} -- For HideableName
module Symantic.Parser.Machine.View where
import Data.Bool (Bool(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Tuple (fst)
-import GHC.TypeLits (symbolVal)
import Text.Show (Show(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
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.Parser.Grammar.ObserveSharing (ShowLetName(..))
+import Symantic.Semantics.Data (normalOrderReduction)
+import Symantic.Parser.Grammar.Combinators (UnscopedRegister(..))
+import Symantic.Parser.Grammar.SharingObserver
import Symantic.Parser.Machine.Instructions
-import Symantic.Univariant.Letable (SomeLet(..))
import Symantic.Parser.Machine.Generate
-- * Type 'ViewMachine'
data ViewMachine (showName::Bool) inp (vs:: [Type]) a
= ViewMachine
{ viewGen :: Gen inp vs a
- -- ^ Provide 'GenAnalysis', which next important for debugging
+ -- ^ Provide 'GenAnalysis', which is important for debugging
-- and improving golden tests, see 'viewInstrCmd'.
, unViewMachine ::
- CallTrace ->
- LetMap GenAnalysis -> -- Output of 'runGenAnalysis'.
+ 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 ->
- LetMap GenAnalysis ->
+ 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 [] (runGenAnalysis (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
- raiseException lbl err = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("raiseException "<>show (symbolVal lbl), "") [] : next
- , viewGen = gen
- } where gen = raiseException lbl err
- popException lbl k = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("popException "<>show (symbolVal lbl), "") [] :
- unViewMachine k ct lm next
- , viewGen = gen
- } where gen = popException lbl (viewGen k)
- catchException lbl ok ko = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("catchException "<>show (symbolVal lbl), "")
- [ viewInstrArg "ok" (unViewMachine ok ct lm [])
- , viewInstrArg "ko" (unViewMachine ko ct lm [])
+instance
+ HideableName sN =>
+ InstrExceptionable (ViewMachine sN) where
+ raise exn = ViewMachine
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("raise "<>show exn, "") [] : next
+ , viewGen = gen
+ } where gen = raise exn
+ fail fs = ViewMachine
+ { unViewMachine = \lm next ->
+ viewInstrCmd @sN (Right gen) lm ("fail "<>show (Set.toList fs), "") [] : next
+ , viewGen = gen
+ } where gen = fail fs
+ commit exn k = ViewMachine
+ { 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 = \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 = catchException lbl (viewGen ok) (viewGen ko)
-instance InstrBranchable (ViewMachine sN) where
+ } where gen = catch exn (viewGen ok) (viewGen ko)
+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 ps bs d = ViewMachine
- { unViewMachine = \ct lm next ->
- viewInstrCmd (Right gen) ct lm ("choicesBranch "<>show ps, "") (
- ((\b -> viewInstrArg "branch" $ unViewMachine b ct lm []) <$> bs) <>
- [ viewInstrArg "default" (unViewMachine d ct lm []) ]
+ choicesBranch bs d = ViewMachine
+ { 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 ps (viewGen <$> bs) (viewGen d)
+ } 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
+instance
+ ( 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
+ HideableName sN =>
+ InstrIterable (ViewMachine sN) where
+ iter jumpName@(LetName n) ok ko = ViewMachine
+ { 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
+ HideableName sN =>
+ InstrRegisterable (ViewMachine sN) where
+ newRegister reg@(UnscopedRegister r) k = ViewMachine
+ { 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 = \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 = \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