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