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