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