src/Symantic/Parser/Machine/View.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE UndecidableInstances #-} -- For ShowLetName
   3 module Symantic.Parser.Machine.View where
   4
   5 import Data.Bool (Bool(..))
   6 import Data.Either (Either(..))
   7 import Data.Function (($), (.), id, on)
   8 import Data.Functor ((<$>))
   9 import Data.Kind (Type)
  10 import Data.Ord (Ord(..))
  11 import Data.Semigroup (Semigroup(..))
  12 import Data.String (String)
  13 import Data.Tuple (fst)
  14 import Text.Show (Show(..))
  15 import qualified Data.HashMap.Strict as HM
  16 import qualified Data.List as List
  17 import qualified Data.Map.Strict as Map
  18 import qualified Data.Tree as Tree
  19 import qualified Language.Haskell.TH.Syntax as TH
  20 import Prelude (error)
  21
  22 import Symantic.Parser.Grammar.ObserveSharing (ShowLetName(..))
  23 import Symantic.Parser.Machine.Instructions
  24 import Symantic.Univariant.Letable (SomeLet(..))
  25 import Symantic.Parser.Machine.Generate
  26
  27 -- * Type 'ViewMachine'
  28 data ViewMachine (showName::Bool) inp (vs:: [Type]) a
  29   =  ViewMachine
  30   { viewGen :: Gen inp vs a
  31     -- ^ Provide 'GenAnalysis', which next important for debugging
  32     -- and improving golden tests, see 'viewInstrCmd'.
  33   , unViewMachine ::
  34       CallTrace ->
  35       LetMap GenAnalysis -> -- Output of 'runGenAnalysis'.
  36       Tree.Forest (String, String) ->
  37       Tree.Forest (String, String)
  38   }
  39
  40 viewMachine ::
  41   ViewMachine sN inp vs a ->
  42   ViewMachine sN inp vs a
  43 viewMachine = id
  44
  45 -- | Helper to view a command.
  46 viewInstrCmd ::
  47   Either TH.Name (Gen inp vs a) ->
  48   CallTrace ->
  49   LetMap GenAnalysis ->
  50   (String, String) -> Tree.Forest (String, String) -> Tree.Tree (String, String)
  51 viewInstrCmd gen ct lm (n, no) = Tree.Node $ (n
  52   <> "\nminReads="<>showsPrec 11 (minReads ga) ""
  53   <> "\nmayRaise="<>showsPrec 11 (Map.keys (mayRaise ga)) ""
  54   , no)
  55   where
  56   ga = case gen of
  57          Right r -> (\f -> f ct) $ genAnalysis r $ (\f _ct -> f) <$> lm
  58          Left l -> HM.findWithDefault (error (show (l, HM.keys lm))) l lm
  59
  60 -- | Helper to view an argument.
  61 viewInstrArg :: String -> Tree.Forest (String, String) -> Tree.Tree (String, String)
  62 viewInstrArg n = Tree.Node $ ("<"<>n<>">", "")
  63
  64 instance Show (ViewMachine sN inp vs a) where
  65   show vm = List.unlines $ drawTrees $
  66       unViewMachine vm [] (runGenAnalysis (genAnalysisByLet (viewGen vm))) []
  67     where
  68     draw :: Tree.Tree (String, String) -> [String]
  69     draw (Tree.Node (x, n) ts0) =
  70       shift "" "  " (List.zipWith (<>) (List.lines x) (n : List.repeat "")) <>
  71       shift "| " "| " (drawTrees ts0)
  72     drawTrees [] = []
  73     drawTrees [t] = draw t
  74     drawTrees (t:ts) = draw t <> drawTrees ts
  75     shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)
  76
  77 instance InstrValuable (ViewMachine sN) where
  78   pushValue a k = ViewMachine
  79     { unViewMachine = \ct lm next ->
  80         viewInstrCmd (Right gen) ct lm ("pushValue "<>showsPrec 10 a "", "") [] :
  81         unViewMachine k ct lm next
  82     , viewGen = gen
  83     } where gen = pushValue a (viewGen k)
  84   popValue k = ViewMachine
  85     { unViewMachine = \ct lm next ->
  86         viewInstrCmd (Right gen) ct lm ("popValue", "") [] :
  87         unViewMachine k ct lm next
  88     , viewGen = gen
  89     } where gen = popValue (viewGen k)
  90   lift2Value f k = ViewMachine
  91     { unViewMachine = \ct lm next ->
  92         viewInstrCmd (Right gen) ct lm ("lift2Value "<>showsPrec 10 f "", "") [] :
  93         unViewMachine k ct lm next
  94     , viewGen = gen
  95     } where gen = lift2Value f (viewGen k)
  96   swapValue k = ViewMachine
  97     { unViewMachine = \ct lm next ->
  98         viewInstrCmd (Right gen) ct lm ("swapValue", "") [] :
  99         unViewMachine k ct lm next
 100     , viewGen = gen
 101     } where gen = swapValue (viewGen k)
 102 instance InstrExceptionable (ViewMachine sN) where
 103   raise exn = ViewMachine
 104     { unViewMachine = \ct lm next ->
 105         viewInstrCmd (Right gen) ct lm ("raise "<>show exn, "") [] : next
 106     , viewGen = gen
 107     } where gen = raise exn
 108   fail flr = ViewMachine
 109     { unViewMachine = \ct lm next ->
 110         viewInstrCmd (Right gen) ct lm ("fail "<>show flr, "") [] : next
 111     , viewGen = gen
 112     } where gen = fail flr
 113   commit exn k = ViewMachine
 114     { unViewMachine = \ct lm next ->
 115         viewInstrCmd (Right gen) ct lm ("commit "<>show exn, "") [] :
 116         unViewMachine k ct lm next
 117     , viewGen = gen
 118     } where gen = commit exn (viewGen k)
 119   catch exn ok ko = ViewMachine
 120     { unViewMachine = \ct lm next ->
 121         viewInstrCmd (Right gen) ct lm ("catch "<>show exn, "")
 122           [ viewInstrArg "ok" (unViewMachine ok ct lm [])
 123           , viewInstrArg "ko" (unViewMachine ko ct lm [])
 124           ] : next
 125     , viewGen = gen
 126     } where gen = catch exn (viewGen ok) (viewGen ko)
 127 instance InstrBranchable (ViewMachine sN) where
 128   caseBranch l r = ViewMachine
 129     { unViewMachine = \ct lm next ->
 130         viewInstrCmd (Right gen) ct lm ("case", "")
 131           [ viewInstrArg "left" (unViewMachine l ct lm [])
 132           , viewInstrArg "right" (unViewMachine r ct lm [])
 133           ] : next
 134     , viewGen = gen
 135     } where gen = caseBranch (viewGen l) (viewGen r)
 136   choicesBranch ps bs d = ViewMachine
 137     { unViewMachine = \ct lm next ->
 138         viewInstrCmd (Right gen) ct lm ("choicesBranch "<>show ps, "") (
 139           ((\b -> viewInstrArg "branch" $ unViewMachine b ct lm []) <$> bs) <>
 140           [ viewInstrArg "default" (unViewMachine d ct lm []) ]
 141         ) : next
 142     , viewGen = gen
 143     } where gen = choicesBranch ps (viewGen <$> bs) (viewGen d)
 144 instance
 145   ShowLetName sN TH.Name =>
 146   InstrCallable (ViewMachine sN) where
 147   defLet defs k = ViewMachine
 148     { unViewMachine = \ct lm next ->
 149         (<> unViewMachine k ct lm next) $
 150         List.sortBy (compare `on` (((fst <$>) <$>) . Tree.levels)) $
 151         ((\(n, SomeLet sub) ->
 152           viewInstrCmd (Left n) ct lm
 153             ("let", " "<>showLetName @sN n)
 154             (unViewMachine sub ct lm []))
 155           <$> HM.toList defs)
 156     , viewGen = gen
 157     } where gen = defLet ((\(SomeLet x) -> SomeLet (viewGen x)) <$> defs) (viewGen k)
 158   jump ln@(LetName n) = ViewMachine
 159     { unViewMachine = \ct lm next ->
 160         viewInstrCmd (Right gen) ct lm ("jump", " "<>showLetName @sN n) [] : next
 161     , viewGen = gen
 162     } where gen = jump ln
 163   call ln@(LetName n) k = ViewMachine
 164     { unViewMachine = \ct lm next ->
 165         viewInstrCmd (Right gen) ct lm ("call", " "<>showLetName @sN n) [] :
 166         unViewMachine k (n:ct) lm next
 167     , viewGen = gen
 168     } where gen = call ln (viewGen k)
 169   ret = ViewMachine
 170     { unViewMachine = \ct lm next ->
 171         viewInstrCmd (Right gen) ct lm ("ret", "") [] : next
 172     , viewGen = gen
 173     } where gen = ret
 174 instance
 175   ShowLetName sN TH.Name =>
 176   InstrJoinable (ViewMachine sN) where
 177   defJoin ln@(LetName n) j k = ViewMachine
 178     { unViewMachine = \ct lm next ->
 179         viewInstrCmd (Left n) ct lm
 180           ("join", " "<>showLetName @sN n)
 181           (unViewMachine j ct lm []) :
 182         unViewMachine k (n:ct) lm next
 183     , viewGen = gen
 184     } where gen = defJoin ln (viewGen j) (viewGen k)
 185   refJoin ln@(LetName n) = ViewMachine
 186     { unViewMachine = \ct lm next ->
 187         viewInstrCmd (Right gen) ct lm ("refJoin", " "<>showLetName @sN n) [] : next
 188     , viewGen = gen
 189     } where gen = refJoin ln
 190 instance InstrInputable (ViewMachine sN) where
 191   pushInput k = ViewMachine
 192     { unViewMachine = \ct lm next ->
 193         viewInstrCmd (Right gen) ct lm ("pushInput", "") [] :
 194         unViewMachine k ct lm next
 195     , viewGen = gen
 196     } where gen = pushInput (viewGen k)
 197   loadInput k = ViewMachine
 198     { unViewMachine = \ct lm next ->
 199         viewInstrCmd (Right gen) ct lm ("loadInput", "") [] :
 200         unViewMachine k ct lm next
 201     , viewGen = gen
 202     } where gen = loadInput (viewGen k)
 203 instance InstrReadable tok Gen => InstrReadable tok (ViewMachine sN) where
 204   read es p k = ViewMachine
 205     { unViewMachine = \ct lm next ->
 206         viewInstrCmd (Right gen) ct lm ("read "<>showsPrec 10 p "", "") [] :
 207         unViewMachine k ct lm next
 208     , viewGen = gen
 209     } where gen = read es p (viewGen k)