src/Symantic/Parser/Machine/View.hs

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