src/Symantic/Parser/Machine/View.hs

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