src/Symantic/Parser/Machine/View.hs

   1 {-# LANGUAGE UndecidableInstances #-} -- For ShowLetName
   2 module Symantic.Parser.Machine.View where
   3
   4 import Data.Bool (Bool(..))
   5 import Data.Function (($), (.), id)
   6 import Data.Functor ((<$>))
   7 import Data.Kind (Type)
   8 import Data.Semigroup (Semigroup(..))
   9 import Data.String (String, IsString(..))
  10 import Text.Show (Show(..))
  11 import qualified Data.Tree as Tree
  12 import qualified Data.List as List
  13 import qualified Language.Haskell.TH.Syntax as TH
  14
  15 import Symantic.Parser.Grammar.ObserveSharing (ShowLetName(..))
  16 import Symantic.Parser.Machine.Instructions
  17
  18 -- * Type 'ViewMachine'
  19 newtype ViewMachine (showName::Bool) inp (vs:: [Type]) (es::Peano) a
  20   =     ViewMachine { unViewMachine ::
  21   Tree.Forest String -> Tree.Forest String }
  22
  23 viewMachine ::
  24   ViewMachine sN inp vs es a ->
  25   ViewMachine sN inp vs es a
  26 viewMachine = id
  27
  28 -- | Helper to view a command.
  29 viewInstrCmd :: String -> Tree.Forest String -> Tree.Tree String
  30 viewInstrCmd n = Tree.Node n
  31 -- | Helper to view an argument.
  32 viewInstrArg :: String -> Tree.Forest String -> Tree.Tree String
  33 viewInstrArg n = Tree.Node ("<"<>n<>">")
  34
  35 instance Show (ViewMachine sN inp vs es a) where
  36   show = drawTree . Tree.Node "" . ($ []) . unViewMachine
  37     where
  38     drawTree :: Tree.Tree String -> String
  39     drawTree  = List.unlines . draw
  40     draw :: Tree.Tree String -> [String]
  41     draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0
  42       where
  43       drawSubTrees [] = []
  44       drawSubTrees [t] = shift "" "  " (draw t)
  45       drawSubTrees (t:ts) = shift "" "| " (draw t) <> drawSubTrees ts
  46       shift first other = List.zipWith (<>) (first : List.repeat other)
  47 instance IsString (ViewMachine sN inp vs es a) where
  48   fromString s = ViewMachine $ \is -> Tree.Node (fromString s) [] : is
  49
  50 instance Stackable (ViewMachine sN) where
  51   push a k = ViewMachine $ \is -> viewInstrCmd ("push "<>showsPrec 10 a "") [] : unViewMachine k is
  52   pop k = ViewMachine $ \is -> viewInstrCmd "pop" [] : unViewMachine k is
  53   liftI2 f k = ViewMachine $ \is -> viewInstrCmd ("lift "<>showsPrec 10 f "") [] : unViewMachine k is
  54   swap k = ViewMachine $ \is -> viewInstrCmd "swap" [] : unViewMachine k is
  55 instance Branchable (ViewMachine sN) where
  56   caseI l r = ViewMachine $ \is -> viewInstrCmd "case"
  57     [ viewInstrArg "left" (unViewMachine l [])
  58     , viewInstrArg "right" (unViewMachine r [])
  59     ] : is
  60   choices ps bs d = ViewMachine $ \is ->
  61     viewInstrCmd ("choices "<>show ps) (
  62       (viewInstrArg "branch" . ($ []) . unViewMachine <$> bs) <>
  63       [ viewInstrArg "default" (unViewMachine d []) ]
  64     ) : is
  65 instance Failable (ViewMachine sN) where
  66   fail _err = ViewMachine $ \is -> viewInstrCmd "fail" [] : is
  67   popFail k = ViewMachine $ \is -> viewInstrCmd "popFail" [] : unViewMachine k is
  68   catchFail t h = ViewMachine $ \is -> viewInstrCmd "catchFail"
  69     [ viewInstrArg "try" (unViewMachine t [])
  70     , viewInstrArg "handler" (unViewMachine h [])
  71     ] : is
  72 instance Inputable (ViewMachine sN) where
  73   loadInput k = ViewMachine $ \is -> viewInstrCmd "loadInput" [] : unViewMachine k is
  74   pushInput k = ViewMachine $ \is -> viewInstrCmd "pushInput" [] : unViewMachine k is
  75 instance
  76   ShowLetName sN TH.Name =>
  77   Routinable (ViewMachine sN) where
  78   subroutine (LetName n) sub k = ViewMachine $ \is ->
  79     Tree.Node (showLetName @sN n<>":") (unViewMachine sub [])
  80     : unViewMachine k is
  81   jump (LetName n) = ViewMachine $ \is -> viewInstrCmd ("jump "<>showLetName @sN n) [] : is
  82   call (LetName n) k = ViewMachine $ \is -> viewInstrCmd ("call "<>showLetName @sN n) [] : unViewMachine k is
  83   ret = ViewMachine $ \is -> viewInstrCmd "ret" [] : is
  84 instance
  85   ShowLetName sN TH.Name =>
  86   Joinable (ViewMachine sN) where
  87   defJoin (LetName n) j k = ViewMachine $ \is ->
  88     Tree.Node (showLetName @sN n<>":") (unViewMachine j [])
  89     : unViewMachine k is
  90   refJoin (LetName n) = ViewMachine $ \is -> viewInstrCmd ("refJoin "<>showLetName @sN n) [] : is
  91 instance Readable tok (ViewMachine sN) where
  92   read _es p k = ViewMachine $ \is -> viewInstrCmd ("read "<>showsPrec 10 p "") [] : unViewMachine k is