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