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 finalByLet (cmd, no) = Tree.Node $ (cmd
  57   <> "\nminReads="<>showsPrec 11 (minReads ga) ""
  58   <> "\nmayRaise="<>show (Map.keys (mayRaise ga))
  59   <> "\nalwaysRaise="<>show (Set.toList (alwaysRaise ga))
  60   <> "\nfreeRegs="<>show (hideableName @sN (Set.toList (freeRegs ga)))
  61   , no)
  62   where
  63   ga = case gen of
  64          Right a -> genAnalysis a finalByLet
  65          Left n -> HM.findWithDefault (error (show (n, HM.keys finalByLet))) n finalByLet
  66
  67 -- | Helper to view an argument.
  68 viewInstrArg :: String -> Tree.Forest (String, String) -> Tree.Tree (String, String)
  69 viewInstrArg n = Tree.Node $ ("<"<>n<>">", "")
  70
  71 instance Show (ViewMachine sN inp vs a) where
  72   show vm = List.unlines $ drawTrees $
  73       unViewMachine vm (mutualFix (genAnalysisByLet (viewGen vm))) []
  74     where
  75     draw :: Tree.Tree (String, String) -> [String]
  76     draw (Tree.Node (x, n) ts0) =
  77       shift "" "  " (List.zipWith (<>) (List.lines x) (n : List.repeat "")) <>
  78       shift "| " "| " (drawTrees ts0)
  79     drawTrees [] = []
  80     drawTrees [t] = draw t
  81     drawTrees (t:ts) = draw t <> drawTrees ts
  82     shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)
  83
  84 instance
  85   HideableName sN =>
  86   InstrComment (ViewMachine sN) where
  87   comment msg k = ViewMachine
  88     { unViewMachine = \lm next ->
  89         viewInstrCmd @sN (Right gen) lm ("comment "<>show msg, "") [] :
  90         unViewMachine k lm next
  91     , viewGen = gen
  92     } where gen = comment msg (viewGen k)
  93 instance
  94   HideableName sN =>
  95   InstrValuable (ViewMachine sN) where
  96   pushValue a k = ViewMachine
  97     { unViewMachine = \lm next ->
  98         viewInstrCmd @sN (Right gen) lm ("pushValue "<>showSplice a, "") [] :
  99         unViewMachine k lm next
 100     , viewGen = gen
 101     } where gen = pushValue a (viewGen k)
 102   popValue k = ViewMachine
 103     { unViewMachine = \lm next ->
 104         viewInstrCmd @sN (Right gen) lm ("popValue", "") [] :
 105         unViewMachine k lm next
 106     , viewGen = gen
 107     } where gen = popValue (viewGen k)
 108   lift2Value f k = ViewMachine
 109     { unViewMachine = \lm next ->
 110         viewInstrCmd @sN (Right gen) lm ("lift2Value "<>showSplice f, "") [] :
 111         unViewMachine k lm next
 112     , viewGen = gen
 113     } where gen = lift2Value f (viewGen k)
 114   swapValue k = ViewMachine
 115     { unViewMachine = \lm next ->
 116         viewInstrCmd @sN (Right gen) lm ("swapValue", "") [] :
 117         unViewMachine k lm next
 118     , viewGen = gen
 119     } where gen = swapValue (viewGen k)
 120 instance
 121   HideableName sN =>
 122   InstrExceptionable (ViewMachine sN) where
 123   raise exn = ViewMachine
 124     { unViewMachine = \lm next ->
 125         viewInstrCmd @sN (Right gen) lm ("raise "<>show exn, "") [] : next
 126     , viewGen = gen
 127     } where gen = raise exn
 128   fail fs = ViewMachine
 129     { unViewMachine = \lm next ->
 130         viewInstrCmd @sN (Right gen) lm ("fail "<>show (Set.toList fs), "") [] : next
 131     , viewGen = gen
 132     } where gen = fail fs
 133   commit exn k = ViewMachine
 134     { unViewMachine = \lm next ->
 135         viewInstrCmd @sN (Right gen) lm ("commit "<>show exn, "") [] :
 136         unViewMachine k lm next
 137     , viewGen = gen
 138     } where gen = commit exn (viewGen k)
 139   catch exn ok ko = ViewMachine
 140     { unViewMachine = \lm next ->
 141         viewInstrCmd @sN (Right gen) lm ("catch "<>show exn, "")
 142           [ viewInstrArg "catchScope" (unViewMachine ok lm [])
 143           , viewInstrArg ("onException "<>show exn) (unViewMachine ko lm [])
 144           ] : next
 145     , viewGen = gen
 146     } where gen = catch exn (viewGen ok) (viewGen ko)
 147 instance
 148   HideableName sN =>
 149   InstrBranchable (ViewMachine sN) where
 150   caseBranch l r = ViewMachine
 151     { unViewMachine = \lm next ->
 152         viewInstrCmd @sN (Right gen) lm ("case", "")
 153           [ viewInstrArg "left" (unViewMachine l lm [])
 154           , viewInstrArg "right" (unViewMachine r lm [])
 155           ] : next
 156     , viewGen = gen
 157     } where gen = caseBranch (viewGen l) (viewGen r)
 158   choicesBranch bs d = ViewMachine
 159     { unViewMachine = \lm next ->
 160         viewInstrCmd @sN (Right gen) lm ("choicesBranch", "") (
 161           ((\(p, b) -> viewInstrArg ("branch "<>showSplice p) $
 162             unViewMachine b lm []) <$> bs) <>
 163           [ viewInstrArg "default" (unViewMachine d lm []) ]
 164         ) : next
 165     , viewGen = gen
 166     } where gen = choicesBranch ((viewGen <$>) <$> bs) (viewGen d)
 167 instance
 168   HideableName sN =>
 169   InstrCallable (ViewMachine sN) where
 170   defLet defs k = ViewMachine
 171     { unViewMachine = \lm next ->
 172         (<> unViewMachine k lm next) $
 173         List.sortBy (compare `on` (((fst <$>) <$>) . Tree.levels)) $
 174         ((\(n, SomeLet sub) ->
 175           viewInstrCmd @sN (Left n) lm
 176             ("let", " "<>show (hideableName @sN n))
 177             (unViewMachine sub lm []))
 178           <$> HM.toList defs)
 179     , viewGen = gen
 180     } where gen = defLet ((\(SomeLet x) -> SomeLet (viewGen x)) <$> defs) (viewGen k)
 181   jump isRec ln@(LetName n) = ViewMachine
 182     { unViewMachine = \lm next ->
 183         viewInstrCmd @sN (Right gen) lm ("jump", " "<>show (hideableName @sN n)) [] : next
 184     , viewGen = gen
 185     } where gen = jump isRec ln
 186   call isRec ln@(LetName n) k = ViewMachine
 187     { unViewMachine = \lm next ->
 188         viewInstrCmd @sN (Right gen) lm ("call", " "<>show (hideableName @sN n)) [] :
 189         unViewMachine k lm next
 190     , viewGen = gen
 191     } where gen = call isRec ln (viewGen k)
 192   ret = ViewMachine
 193     { unViewMachine = \lm next ->
 194         viewInstrCmd @sN (Right gen) lm ("ret", "") [] : next
 195     , viewGen = gen
 196     } where gen = ret
 197 instance
 198   HideableName sN =>
 199   InstrJoinable (ViewMachine sN) where
 200   defJoin ln@(LetName n) sub k = ViewMachine
 201     { unViewMachine = \lm next ->
 202         viewInstrCmd @sN (Left n) lm
 203           ("join", " "<>show (hideableName @sN n))
 204           (unViewMachine sub lm []) :
 205         unViewMachine k lm next
 206     , viewGen = gen
 207     } where gen = defJoin ln (viewGen sub) (viewGen k)
 208   refJoin ln@(LetName n) = ViewMachine
 209     { unViewMachine = \lm next ->
 210         viewInstrCmd @sN (Right gen) lm ("refJoin", " "<>show (hideableName @sN n)) [] : next
 211     , viewGen = gen
 212     } where gen = refJoin ln
 213 instance
 214   HideableName sN =>
 215   InstrInputable (ViewMachine sN) where
 216   saveInput k = ViewMachine
 217     { unViewMachine = \lm next ->
 218         viewInstrCmd @sN (Right gen) lm ("saveInput", "") [] :
 219         unViewMachine k lm next
 220     , viewGen = gen
 221     } where gen = saveInput (viewGen k)
 222   loadInput k = ViewMachine
 223     { unViewMachine = \lm next ->
 224         viewInstrCmd @sN (Right gen) lm ("loadInput", "") [] :
 225         unViewMachine k lm next
 226     , viewGen = gen
 227     } where gen = loadInput (viewGen k)
 228 instance
 229   ( HideableName sN
 230   , InstrReadable tok Gen
 231   ) => InstrReadable tok (ViewMachine sN) where
 232   read es p k = ViewMachine
 233     { unViewMachine = \lm next ->
 234         viewInstrCmd @sN (Right gen) lm ("read "<>showSplice p, "") [] :
 235         unViewMachine k lm next
 236     , viewGen = gen
 237     } where gen = read es p (viewGen k)
 238 instance
 239   HideableName sN =>
 240   InstrIterable (ViewMachine sN) where
 241   iter jumpName@(LetName n) ok ko = ViewMachine
 242     { unViewMachine = \lm next ->
 243         viewInstrCmd @sN (Right gen) lm ("iter", " "<>show (hideableName @sN n))
 244           [ viewInstrArg "ok" (unViewMachine ok lm [])
 245           , viewInstrArg "ko" (unViewMachine ko lm [])
 246           ] : next
 247     , viewGen = gen
 248     } where gen = iter jumpName (viewGen ok) (viewGen ko)
 249 instance
 250   HideableName sN =>
 251   InstrRegisterable (ViewMachine sN) where
 252   newRegister reg@(UnscopedRegister r) k = ViewMachine
 253     { unViewMachine = \lm next ->
 254         viewInstrCmd @sN (Right gen) lm ("newRegister", " "<>show (hideableName @sN r)) [] :
 255         unViewMachine k lm next
 256     , viewGen = gen
 257     } where gen = newRegister reg (viewGen k)
 258   readRegister reg@(UnscopedRegister r) k = ViewMachine
 259     { unViewMachine = \lm next ->
 260         viewInstrCmd @sN (Right gen) lm ("readRegister", " "<>show (hideableName @sN r)) [] :
 261         unViewMachine k lm next
 262     , viewGen = gen
 263     } where gen = readRegister reg (viewGen k)
 264   writeRegister reg@(UnscopedRegister r) k = ViewMachine
 265     { unViewMachine = \lm next ->
 266         viewInstrCmd @sN (Right gen) lm ("writeRegister", " "<>show (hideableName @sN r)) [] :
 267         unViewMachine k lm next
 268     , viewGen = gen
 269     } where gen = writeRegister reg (viewGen k)