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 GHC.TypeLits (symbolVal)
  15 import Text.Show (Show(..))
  16 import qualified Data.HashMap.Strict as HM
  17 import qualified Data.List as List
  18 import qualified Data.Map.Strict as Map
  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.Univariant.Letable (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   raiseException lbl err = ViewMachine
 105     { unViewMachine = \ct lm next ->
 106         viewInstrCmd (Right gen) ct lm ("raiseException "<>show (symbolVal lbl), "") [] : next
 107     , viewGen = gen
 108     } where gen = raiseException lbl err
 109   popException lbl k = ViewMachine
 110     { unViewMachine = \ct lm next ->
 111         viewInstrCmd (Right gen) ct lm ("popException "<>show (symbolVal lbl), "") [] :
 112         unViewMachine k ct lm next
 113     , viewGen = gen
 114     } where gen = popException lbl (viewGen k)
 115   catchException lbl ok ko = ViewMachine
 116     { unViewMachine = \ct lm next ->
 117         viewInstrCmd (Right gen) ct lm ("catchException "<>show (symbolVal lbl), "")
 118           [ viewInstrArg "ok" (unViewMachine ok ct lm [])
 119           , viewInstrArg "ko" (unViewMachine ko ct lm [])
 120           ] : next
 121     , viewGen = gen
 122     } where gen = catchException lbl (viewGen ok) (viewGen ko)
 123 instance InstrBranchable (ViewMachine sN) where
 124   caseBranch l r = ViewMachine
 125     { unViewMachine = \ct lm next ->
 126         viewInstrCmd (Right gen) ct lm ("case", "")
 127           [ viewInstrArg "left" (unViewMachine l ct lm [])
 128           , viewInstrArg "right" (unViewMachine r ct lm [])
 129           ] : next
 130     , viewGen = gen
 131     } where gen = caseBranch (viewGen l) (viewGen r)
 132   choicesBranch ps bs d = ViewMachine
 133     { unViewMachine = \ct lm next ->
 134         viewInstrCmd (Right gen) ct lm ("choicesBranch "<>show ps, "") (
 135           ((\b -> viewInstrArg "branch" $ unViewMachine b ct lm []) <$> bs) <>
 136           [ viewInstrArg "default" (unViewMachine d ct lm []) ]
 137         ) : next
 138     , viewGen = gen
 139     } where gen = choicesBranch ps (viewGen <$> bs) (viewGen d)
 140 instance
 141   ShowLetName sN TH.Name =>
 142   InstrCallable (ViewMachine sN) where
 143   defLet defs k = ViewMachine
 144     { unViewMachine = \ct lm next ->
 145         (<> unViewMachine k ct lm next) $
 146         List.sortBy (compare `on` (((fst <$>) <$>) . Tree.levels)) $
 147         ((\(n, SomeLet sub) ->
 148           viewInstrCmd (Left n) ct lm
 149             ("let", " "<>showLetName @sN n)
 150             (unViewMachine sub ct lm []))
 151           <$> HM.toList defs)
 152     , viewGen = gen
 153     } where gen = defLet ((\(SomeLet x) -> SomeLet (viewGen x)) <$> defs) (viewGen k)
 154   jump ln@(LetName n) = ViewMachine
 155     { unViewMachine = \ct lm next ->
 156         viewInstrCmd (Right gen) ct lm ("jump", " "<>showLetName @sN n) [] : next
 157     , viewGen = gen
 158     } where gen = jump ln
 159   call ln@(LetName n) k = ViewMachine
 160     { unViewMachine = \ct lm next ->
 161         viewInstrCmd (Right gen) ct lm ("call", " "<>showLetName @sN n) [] :
 162         unViewMachine k (n:ct) lm next
 163     , viewGen = gen
 164     } where gen = call ln (viewGen k)
 165   ret = ViewMachine
 166     { unViewMachine = \ct lm next ->
 167         viewInstrCmd (Right gen) ct lm ("ret", "") [] : next
 168     , viewGen = gen
 169     } where gen = ret
 170 instance
 171   ShowLetName sN TH.Name =>
 172   InstrJoinable (ViewMachine sN) where
 173   defJoin ln@(LetName n) j k = ViewMachine
 174     { unViewMachine = \ct lm next ->
 175         viewInstrCmd (Left n) ct lm
 176           ("join", " "<>showLetName @sN n)
 177           (unViewMachine j ct lm []) :
 178         unViewMachine k (n:ct) lm next
 179     , viewGen = gen
 180     } where gen = defJoin ln (viewGen j) (viewGen k)
 181   refJoin ln@(LetName n) = ViewMachine
 182     { unViewMachine = \ct lm next ->
 183         viewInstrCmd (Right gen) ct lm ("refJoin", " "<>showLetName @sN n) [] : next
 184     , viewGen = gen
 185     } where gen = refJoin ln
 186 instance InstrInputable (ViewMachine sN) where
 187   pushInput k = ViewMachine
 188     { unViewMachine = \ct lm next ->
 189         viewInstrCmd (Right gen) ct lm ("pushInput", "") [] :
 190         unViewMachine k ct lm next
 191     , viewGen = gen
 192     } where gen = pushInput (viewGen k)
 193   loadInput k = ViewMachine
 194     { unViewMachine = \ct lm next ->
 195         viewInstrCmd (Right gen) ct lm ("loadInput", "") [] :
 196         unViewMachine k ct lm next
 197     , viewGen = gen
 198     } where gen = loadInput (viewGen k)
 199 instance InstrReadable tok Gen => InstrReadable tok (ViewMachine sN) where
 200   read es p k = ViewMachine
 201     { unViewMachine = \ct lm next ->
 202         viewInstrCmd (Right gen) ct lm ("read "<>showsPrec 10 p "", "") [] :
 203         unViewMachine k ct lm next
 204     , viewGen = gen
 205     } where gen = read es p (viewGen k)