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.Combinators (UnscopedRegister(..))
  24 import Symantic.Parser.Grammar.ObserveSharing
  25 import Symantic.Parser.Machine.Instructions
  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 is important for debugging
  33     -- and improving golden tests, see 'viewInstrCmd'.
  34   , unViewMachine ::
  35       LetRecs TH.Name GenAnalysis -> -- Output of 'runOpenRecs'.
  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   LetRecs TH.Name GenAnalysis ->
  49   (String, String) -> Tree.Forest (String, String) -> Tree.Tree (String, String)
  50 viewInstrCmd gen lm (n, no) = Tree.Node $ (n
  51   <> "\nminReads="<>showsPrec 11 (minReads ga) ""
  52   <> "\nmayRaise="<>showsPrec 11 (Map.keys (mayRaise ga)) ""
  53   , no)
  54   where
  55   ga = case gen of
  56          Right r -> genAnalysis r lm
  57          Left l -> HM.findWithDefault (error (show (l, HM.keys lm))) l lm
  58
  59 -- | Helper to view an argument.
  60 viewInstrArg :: String -> Tree.Forest (String, String) -> Tree.Tree (String, String)
  61 viewInstrArg n = Tree.Node $ ("<"<>n<>">", "")
  62
  63 instance Show (ViewMachine sN inp vs a) where
  64   show vm = List.unlines $ drawTrees $
  65       unViewMachine vm (mutualFix (genAnalysisByLet (viewGen vm))) []
  66     where
  67     draw :: Tree.Tree (String, String) -> [String]
  68     draw (Tree.Node (x, n) ts0) =
  69       shift "" "  " (List.zipWith (<>) (List.lines x) (n : List.repeat "")) <>
  70       shift "| " "| " (drawTrees ts0)
  71     drawTrees [] = []
  72     drawTrees [t] = draw t
  73     drawTrees (t:ts) = draw t <> drawTrees ts
  74     shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)
  75
  76 instance InstrValuable (ViewMachine sN) where
  77   pushValue a k = ViewMachine
  78     { unViewMachine = \lm next ->
  79         viewInstrCmd (Right gen) lm ("pushValue "<>showsPrec 10 a "", "") [] :
  80         unViewMachine k lm next
  81     , viewGen = gen
  82     } where gen = pushValue a (viewGen k)
  83   popValue k = ViewMachine
  84     { unViewMachine = \lm next ->
  85         viewInstrCmd (Right gen) lm ("popValue", "") [] :
  86         unViewMachine k lm next
  87     , viewGen = gen
  88     } where gen = popValue (viewGen k)
  89   lift2Value f k = ViewMachine
  90     { unViewMachine = \lm next ->
  91         viewInstrCmd (Right gen) lm ("lift2Value "<>showsPrec 10 f "", "") [] :
  92         unViewMachine k lm next
  93     , viewGen = gen
  94     } where gen = lift2Value f (viewGen k)
  95   swapValue k = ViewMachine
  96     { unViewMachine = \lm next ->
  97         viewInstrCmd (Right gen) lm ("swapValue", "") [] :
  98         unViewMachine k lm next
  99     , viewGen = gen
 100     } where gen = swapValue (viewGen k)
 101 instance InstrExceptionable (ViewMachine sN) where
 102   raise exn = ViewMachine
 103     { unViewMachine = \lm next ->
 104         viewInstrCmd (Right gen) lm ("raise "<>show exn, "") [] : next
 105     , viewGen = gen
 106     } where gen = raise exn
 107   fail flr = ViewMachine
 108     { unViewMachine = \lm next ->
 109         viewInstrCmd (Right gen) lm ("fail "<>show (Set.toList flr), "") [] : next
 110     , viewGen = gen
 111     } where gen = fail flr
 112   commit exn k = ViewMachine
 113     { unViewMachine = \lm next ->
 114         viewInstrCmd (Right gen) lm ("commit "<>show exn, "") [] :
 115         unViewMachine k lm next
 116     , viewGen = gen
 117     } where gen = commit exn (viewGen k)
 118   catch exn ok ko = ViewMachine
 119     { unViewMachine = \lm next ->
 120         viewInstrCmd (Right gen) lm ("catch "<>show exn, "")
 121           [ viewInstrArg "ok" (unViewMachine ok lm [])
 122           , viewInstrArg "ko" (unViewMachine ko lm [])
 123           ] : next
 124     , viewGen = gen
 125     } where gen = catch exn (viewGen ok) (viewGen ko)
 126 instance InstrBranchable (ViewMachine sN) where
 127   caseBranch l r = ViewMachine
 128     { unViewMachine = \lm next ->
 129         viewInstrCmd (Right gen) lm ("case", "")
 130           [ viewInstrArg "left" (unViewMachine l lm [])
 131           , viewInstrArg "right" (unViewMachine r lm [])
 132           ] : next
 133     , viewGen = gen
 134     } where gen = caseBranch (viewGen l) (viewGen r)
 135   choicesBranch bs d = ViewMachine
 136     { unViewMachine = \lm next ->
 137         viewInstrCmd (Right gen) lm ("choicesBranch", "") (
 138           ((\(p, b) -> viewInstrArg ("branch "<>showsPrec 10 p "") $
 139             unViewMachine b lm []) <$> bs) <>
 140           [ viewInstrArg "default" (unViewMachine d lm []) ]
 141         ) : next
 142     , viewGen = gen
 143     } where gen = choicesBranch ((viewGen <$>) <$> bs) (viewGen d)
 144 instance
 145   ShowLetName sN TH.Name =>
 146   InstrCallable (ViewMachine sN) where
 147   defLet defs k = ViewMachine
 148     { unViewMachine = \lm next ->
 149         (<> unViewMachine k lm next) $
 150         List.sortBy (compare `on` (((fst <$>) <$>) . Tree.levels)) $
 151         ((\(n, SomeLet sub) ->
 152           viewInstrCmd (Left n) lm
 153             ("let", " "<>showLetName @sN n)
 154             (unViewMachine sub lm []))
 155           <$> HM.toList defs)
 156     , viewGen = gen
 157     } where gen = defLet ((\(SomeLet x) -> SomeLet (viewGen x)) <$> defs) (viewGen k)
 158   jump isRec ln@(LetName n) = ViewMachine
 159     { unViewMachine = \lm next ->
 160         viewInstrCmd (Right gen) lm ("jump", " "<>showLetName @sN n) [] : next
 161     , viewGen = gen
 162     } where gen = jump isRec ln
 163   call isRec ln@(LetName n) k = ViewMachine
 164     { unViewMachine = \lm next ->
 165         viewInstrCmd (Right gen) lm ("call", " "<>showLetName @sN n) [] :
 166         unViewMachine k lm next
 167     , viewGen = gen
 168     } where gen = call isRec ln (viewGen k)
 169   ret = ViewMachine
 170     { unViewMachine = \lm next ->
 171         viewInstrCmd (Right gen) 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 = \lm next ->
 179         viewInstrCmd (Left n) lm
 180           ("join", " "<>showLetName @sN n)
 181           (unViewMachine j lm []) :
 182         unViewMachine k lm next
 183     , viewGen = gen
 184     } where gen = defJoin ln (viewGen j) (viewGen k)
 185   refJoin ln@(LetName n) = ViewMachine
 186     { unViewMachine = \lm next ->
 187         viewInstrCmd (Right gen) 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 = \lm next ->
 193         viewInstrCmd (Right gen) lm ("pushInput", "") [] :
 194         unViewMachine k lm next
 195     , viewGen = gen
 196     } where gen = pushInput (viewGen k)
 197   loadInput k = ViewMachine
 198     { unViewMachine = \lm next ->
 199         viewInstrCmd (Right gen) lm ("loadInput", "") [] :
 200         unViewMachine k lm next
 201     , viewGen = gen
 202     } where gen = loadInput (viewGen k)
 203 instance
 204   InstrReadable tok Gen =>
 205   InstrReadable tok (ViewMachine sN) where
 206   read es p k = ViewMachine
 207     { unViewMachine = \lm next ->
 208         viewInstrCmd (Right gen) lm ("read "<>showsPrec 10 p "", "") [] :
 209         unViewMachine k lm next
 210     , viewGen = gen
 211     } where gen = read es p (viewGen k)
 212 instance
 213   ShowLetName sN TH.Name =>
 214   InstrIterable (ViewMachine sN) where
 215   iter jumpName@(LetName n) ok ko = ViewMachine
 216     { unViewMachine = \lm next ->
 217         viewInstrCmd (Right gen) lm ("iter", " "<>showLetName @sN n)
 218           [ viewInstrArg "ok" (unViewMachine ok lm [])
 219           , viewInstrArg "ko" (unViewMachine ko lm [])
 220           ] : next
 221     , viewGen = gen
 222     } where gen = iter jumpName (viewGen ok) (viewGen ko)
 223 instance
 224   ShowLetName sN TH.Name =>
 225   InstrRegisterable (ViewMachine sN) where
 226   newRegister reg@(UnscopedRegister r) k = ViewMachine
 227     { unViewMachine = \lm next ->
 228         viewInstrCmd (Right gen) lm ("newRegister", " "<>showLetName @sN r) [] :
 229         unViewMachine k lm next
 230     , viewGen = gen
 231     } where gen = newRegister reg (viewGen k)
 232   readRegister reg@(UnscopedRegister r) k = ViewMachine
 233     { unViewMachine = \lm next ->
 234         viewInstrCmd (Right gen) lm ("readRegister", " "<>showLetName @sN r) [] :
 235         unViewMachine k lm next
 236     , viewGen = gen
 237     } where gen = readRegister reg (viewGen k)
 238   writeRegister reg@(UnscopedRegister r) k = ViewMachine
 239     { unViewMachine = \lm next ->
 240         viewInstrCmd (Right gen) lm ("writeRegister", " "<>showLetName @sN r) [] :
 241         unViewMachine k lm next
 242     , viewGen = gen
 243     } where gen = writeRegister reg (viewGen k)