module Symantic.Parser.Machine.View where import Data.Function (($), (.), id) import Data.Functor ((<$>)) import Data.Kind (Type) import Data.Semigroup (Semigroup(..)) import Data.String (String, IsString(..)) import Text.Show (Show(..)) import qualified Data.Tree as Tree import qualified Data.List as List import Symantic.Parser.Machine.Instructions -- * Type 'ViewMachine' newtype ViewMachine inp (vs:: [Type]) (es::Peano) a = ViewMachine { unViewMachine :: Tree.Forest String -> Tree.Forest String } viewInstr :: ViewMachine inp vs es a -> ViewMachine inp vs es a viewInstr = id -- | Helper to view a command. viewInstrCmd :: String -> Tree.Forest String -> Tree.Tree String viewInstrCmd n = Tree.Node n -- | Helper to view an argument. viewInstrArg :: String -> Tree.Forest String -> Tree.Tree String viewInstrArg n = Tree.Node ("<"<>n<>">") instance Show (ViewMachine inp vs es a) where show = drawTree . Tree.Node "" . ($ []) . unViewMachine where drawTree :: Tree.Tree String -> String drawTree = List.unlines . draw draw :: Tree.Tree String -> [String] draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0 where drawSubTrees [] = [] drawSubTrees [t] = shift "" " " (draw t) drawSubTrees (t:ts) = shift "" "| " (draw t) <> drawSubTrees ts shift first other = List.zipWith (<>) (first : List.repeat other) instance IsString (ViewMachine inp vs es a) where fromString s = ViewMachine $ \is -> Tree.Node (fromString s) [] : is instance Stackable ViewMachine where push a k = ViewMachine $ \is -> viewInstrCmd ("push "<>showsPrec 10 a "") [] : unViewMachine k is pop k = ViewMachine $ \is -> viewInstrCmd "pop" [] : unViewMachine k is liftI2 f k = ViewMachine $ \is -> viewInstrCmd ("lift "<>showsPrec 10 f "") [] : unViewMachine k is swap k = ViewMachine $ \is -> viewInstrCmd "swap" [] : unViewMachine k is instance Branchable ViewMachine where caseI l r = ViewMachine $ \is -> viewInstrCmd "case" [ viewInstrArg "left" (unViewMachine l []) , viewInstrArg "right" (unViewMachine r []) ] : is choices ps bs d = ViewMachine $ \is -> viewInstrCmd ("choices "<>show ps) ( (viewInstrArg "branch" . ($ []) . unViewMachine <$> bs) <> [ viewInstrArg "default" (unViewMachine d []) ] ) : is instance Failable ViewMachine where fail _err = ViewMachine $ \is -> viewInstrCmd "fail" [] : is popFail k = ViewMachine $ \is -> viewInstrCmd "popFail" [] : unViewMachine k is catchFail t h = ViewMachine $ \is -> viewInstrCmd "catchFail" [ viewInstrArg "try" (unViewMachine t []) , viewInstrArg "handler" (unViewMachine h []) ] : is instance Inputable ViewMachine where loadInput k = ViewMachine $ \is -> viewInstrCmd "loadInput" [] : unViewMachine k is pushInput k = ViewMachine $ \is -> viewInstrCmd "pushInput" [] : unViewMachine k is instance Routinable ViewMachine where subroutine n sub k = ViewMachine $ \is -> Tree.Node (show n<>":") (unViewMachine sub []) : unViewMachine k is jump n = ViewMachine $ \is -> viewInstrCmd ("jump "<>show n) [] : is call n k = ViewMachine $ \is -> viewInstrCmd ("call "<>show n) [] : unViewMachine k is ret = ViewMachine $ \is -> viewInstrCmd "ret" [] : is instance Joinable ViewMachine where defJoin n sub k = ViewMachine $ \is -> Tree.Node (show n<>":") (unViewMachine sub []) : unViewMachine k is refJoin n = ViewMachine $ \is -> viewInstrCmd ("refJoin "<>show n) [] : is instance Readable tok ViewMachine where read _es p k = ViewMachine $ \is -> viewInstrCmd ("read "<>showsPrec 10 p "") [] : unViewMachine k is