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.Optimize (normalOrderReduction)
  24 import Symantic.Parser.Grammar.Combinators (UnscopedRegister(..))
  25 import Symantic.Parser.Grammar.ObserveSharing
  26 import Symantic.Parser.Machine.Instructions
  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       LetRecs TH.Name GenAnalysis -> -- Output of 'mutualFix'.
  37       Tree.Forest (String, String) ->
  38       Tree.Forest (String, String)
  39   }
  40
  41 viewMachine :: ViewMachine sN inp vs a -> ViewMachine sN inp vs a
  42 viewMachine = id
  43
  44 showSplice :: Splice a -> String
  45 showSplice p = showsPrec 10 (normalOrderReduction p) ""
  46
  47 -- | Helper to view a command.
  48 viewInstrCmd ::
  49   Either TH.Name (Gen inp vs a) ->
  50   LetRecs TH.Name GenAnalysis ->
  51   (String, String) -> Tree.Forest (String, String) -> Tree.Tree (String, String)
  52 viewInstrCmd gen 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 -> genAnalysis r 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 (mutualFix (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 = \lm next ->
  81         viewInstrCmd (Right gen) lm ("pushValue "<>showSplice a, "") [] :
  82         unViewMachine k lm next
  83     , viewGen = gen
  84     } where gen = pushValue a (viewGen k)
  85   popValue k = ViewMachine
  86     { unViewMachine = \lm next ->
  87         viewInstrCmd (Right gen) lm ("popValue", "") [] :
  88         unViewMachine k lm next
  89     , viewGen = gen
  90     } where gen = popValue (viewGen k)
  91   lift2Value f k = ViewMachine
  92     { unViewMachine = \lm next ->
  93         viewInstrCmd (Right gen) lm ("lift2Value "<>showSplice f, "") [] :
  94         unViewMachine k lm next
  95     , viewGen = gen
  96     } where gen = lift2Value f (viewGen k)
  97   swapValue k = ViewMachine
  98     { unViewMachine = \lm next ->
  99         viewInstrCmd (Right gen) lm ("swapValue", "") [] :
 100         unViewMachine k lm next
 101     , viewGen = gen
 102     } where gen = swapValue (viewGen k)
 103 instance InstrExceptionable (ViewMachine sN) where
 104   raise exn = ViewMachine
 105     { unViewMachine = \lm next ->
 106         viewInstrCmd (Right gen) lm ("raise "<>show exn, "") [] : next
 107     , viewGen = gen
 108     } where gen = raise exn
 109   fail flr = ViewMachine
 110     { unViewMachine = \lm next ->
 111         viewInstrCmd (Right gen) lm ("fail "<>show (Set.toList flr), "") [] : next
 112     , viewGen = gen
 113     } where gen = fail flr
 114   commit exn k = ViewMachine
 115     { unViewMachine = \lm next ->
 116         viewInstrCmd (Right gen) lm ("commit "<>show exn, "") [] :
 117         unViewMachine k lm next
 118     , viewGen = gen
 119     } where gen = commit exn (viewGen k)
 120   catch exn ok ko = ViewMachine
 121     { unViewMachine = \lm next ->
 122         viewInstrCmd (Right gen) lm ("catch "<>show exn, "")
 123           [ viewInstrArg "ok" (unViewMachine ok lm [])
 124           , viewInstrArg "ko" (unViewMachine ko 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 = \lm next ->
 131         viewInstrCmd (Right gen) lm ("case", "")
 132           [ viewInstrArg "left" (unViewMachine l lm [])
 133           , viewInstrArg "right" (unViewMachine r lm [])
 134           ] : next
 135     , viewGen = gen
 136     } where gen = caseBranch (viewGen l) (viewGen r)
 137   choicesBranch bs d = ViewMachine
 138     { unViewMachine = \lm next ->
 139         viewInstrCmd (Right gen) lm ("choicesBranch", "") (
 140           ((\(p, b) -> viewInstrArg ("branch "<>showSplice p) $
 141             unViewMachine b lm []) <$> bs) <>
 142           [ viewInstrArg "default" (unViewMachine d lm []) ]
 143         ) : next
 144     , viewGen = gen
 145     } where gen = choicesBranch ((viewGen <$>) <$> bs) (viewGen d)
 146 instance
 147   ShowLetName sN TH.Name =>
 148   InstrCallable (ViewMachine sN) where
 149   defLet defs k = ViewMachine
 150     { unViewMachine = \lm next ->
 151         (<> unViewMachine k lm next) $
 152         List.sortBy (compare `on` (((fst <$>) <$>) . Tree.levels)) $
 153         ((\(n, SomeLet sub) ->
 154           viewInstrCmd (Left n) lm
 155             ("let", " "<>showLetName @sN n)
 156             (unViewMachine sub lm []))
 157           <$> HM.toList defs)
 158     , viewGen = gen
 159     } where gen = defLet ((\(SomeLet x) -> SomeLet (viewGen x)) <$> defs) (viewGen k)
 160   jump isRec ln@(LetName n) = ViewMachine
 161     { unViewMachine = \lm next ->
 162         viewInstrCmd (Right gen) lm ("jump", " "<>showLetName @sN n) [] : next
 163     , viewGen = gen
 164     } where gen = jump isRec ln
 165   call isRec ln@(LetName n) k = ViewMachine
 166     { unViewMachine = \lm next ->
 167         viewInstrCmd (Right gen) lm ("call", " "<>showLetName @sN n) [] :
 168         unViewMachine k lm next
 169     , viewGen = gen
 170     } where gen = call isRec ln (viewGen k)
 171   ret = ViewMachine
 172     { unViewMachine = \lm next ->
 173         viewInstrCmd (Right gen) lm ("ret", "") [] : next
 174     , viewGen = gen
 175     } where gen = ret
 176 instance
 177   ShowLetName sN TH.Name =>
 178   InstrJoinable (ViewMachine sN) where
 179   defJoin ln@(LetName n) j k = ViewMachine
 180     { unViewMachine = \lm next ->
 181         viewInstrCmd (Left n) lm
 182           ("join", " "<>showLetName @sN n)
 183           (unViewMachine j lm []) :
 184         unViewMachine k lm next
 185     , viewGen = gen
 186     } where gen = defJoin ln (viewGen j) (viewGen k)
 187   refJoin ln@(LetName n) = ViewMachine
 188     { unViewMachine = \lm next ->
 189         viewInstrCmd (Right gen) lm ("refJoin", " "<>showLetName @sN n) [] : next
 190     , viewGen = gen
 191     } where gen = refJoin ln
 192 instance InstrInputable (ViewMachine sN) where
 193   pushInput k = ViewMachine
 194     { unViewMachine = \lm next ->
 195         viewInstrCmd (Right gen) lm ("pushInput", "") [] :
 196         unViewMachine k lm next
 197     , viewGen = gen
 198     } where gen = pushInput (viewGen k)
 199   loadInput k = ViewMachine
 200     { unViewMachine = \lm next ->
 201         viewInstrCmd (Right gen) lm ("loadInput", "") [] :
 202         unViewMachine k lm next
 203     , viewGen = gen
 204     } where gen = loadInput (viewGen k)
 205 instance
 206   InstrReadable tok Gen =>
 207   InstrReadable tok (ViewMachine sN) where
 208   read es p k = ViewMachine
 209     { unViewMachine = \lm next ->
 210         viewInstrCmd (Right gen) lm ("read "<>showSplice p, "") [] :
 211         unViewMachine k lm next
 212     , viewGen = gen
 213     } where gen = read es p (viewGen k)
 214 instance
 215   ShowLetName sN TH.Name =>
 216   InstrIterable (ViewMachine sN) where
 217   iter jumpName@(LetName n) ok ko = ViewMachine
 218     { unViewMachine = \lm next ->
 219         viewInstrCmd (Right gen) lm ("iter", " "<>showLetName @sN n)
 220           [ viewInstrArg "ok" (unViewMachine ok lm [])
 221           , viewInstrArg "ko" (unViewMachine ko lm [])
 222           ] : next
 223     , viewGen = gen
 224     } where gen = iter jumpName (viewGen ok) (viewGen ko)
 225 instance
 226   ShowLetName sN TH.Name =>
 227   InstrRegisterable (ViewMachine sN) where
 228   newRegister reg@(UnscopedRegister r) k = ViewMachine
 229     { unViewMachine = \lm next ->
 230         viewInstrCmd (Right gen) lm ("newRegister", " "<>showLetName @sN r) [] :
 231         unViewMachine k lm next
 232     , viewGen = gen
 233     } where gen = newRegister reg (viewGen k)
 234   readRegister reg@(UnscopedRegister r) k = ViewMachine
 235     { unViewMachine = \lm next ->
 236         viewInstrCmd (Right gen) lm ("readRegister", " "<>showLetName @sN r) [] :
 237         unViewMachine k lm next
 238     , viewGen = gen
 239     } where gen = readRegister reg (viewGen k)
 240   writeRegister reg@(UnscopedRegister r) k = ViewMachine
 241     { unViewMachine = \lm next ->
 242         viewInstrCmd (Right gen) lm ("writeRegister", " "<>showLetName @sN r) [] :
 243         unViewMachine k lm next
 244     , viewGen = gen
 245     } where gen = writeRegister reg (viewGen k)