diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 27 |
1 files changed, 14 insertions, 13 deletions
diff --git a/src/Main.hs b/src/Main.hs index 61dc3bc..faf21f7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,6 +6,7 @@ import Haskell.AST import Haskell.Env import Haskell.Rewrite import Haskell.Parser +import Pretty import System.Environment import System.Exit import System.IO @@ -95,17 +96,17 @@ data UserCmd = UCCmd Cmd deriving (Show) instance Pretty Action where - pretty (Action cmd target) = "action " ++ target ++ " " ++ pretty cmd + pretty (Action cmd target) = Node ("action " ++ target) [pretty cmd] instance Pretty Cmd where - pretty (CRewrite name) = "rew " ++ name - pretty CBeta = "beta" - pretty CEta = "eta" - pretty CCase = "case" - pretty CCaseForce = "case!" - pretty CEtaCase = "etacase" - pretty CCaseCase = "casecase" - pretty (CRepeat cmd) = "repeat " ++ pretty cmd + pretty (CRewrite name) = Leaf ("rew " ++ name) + pretty CBeta = Leaf "beta" + pretty CEta = Leaf "eta" + pretty CCase = Leaf "case" + pretty CCaseForce = Leaf "case!" + pretty CEtaCase = Leaf "etacase" + pretty CCaseCase = Leaf "casecase" + pretty (CRepeat cmd) = Node "repeat" [pretty cmd] topEnv :: Context -> Env topEnv (Context [] env) = env @@ -134,7 +135,7 @@ apply ctx act@(Action cmd target) = case cmd of CRewrite name -> genTransform (\env -> liftM2 (,) (get env name) (get env target)) (\(repl, expr) -> normalise $ rewrite name repl expr) CRepeat subcmd -> case exprTransformer subcmd of - Nothing -> Left $ "Cannot repeat '" ++ pretty subcmd ++ "'" + Nothing -> Left $ "Cannot repeat '" ++ pprint 80 subcmd ++ "'" Just trans -> transform (repeatTrans (normalise . trans)) _ -> transform (normalise . fromJust (exprTransformer cmd)) where @@ -165,13 +166,13 @@ applyUserCmd appstate = \case in case cStack ctx of [] -> return (Left "Empty environment stack") (_:stk) -> return (Right (Just appstate { asCtx = ctx { cStack = stk } })) - CShowEnv -> putStrLn (pretty (topEnv (asCtx appstate))) >> return (Right (Just appstate)) + CShowEnv -> putStrLn (pprint 80 (topEnv (asCtx appstate))) >> return (Right (Just appstate)) CUnFocus -> return (Right (Just appstate { asFocus = Nothing })) CFocus name -> if envContains (topEnv (asCtx appstate)) name then return (Right (Just appstate { asFocus = Just name })) else return (Left "Name doesn't exist") CLog -> do - mapM_ (putStrLn . pretty) $ map fst (reverse $ cStack (asCtx appstate)) + mapM_ (putStrLn . pprint 80) $ map fst (reverse $ cStack (asCtx appstate)) return (Right (Just appstate)) CHelp -> putStrLn usageString >> return (Right (Just appstate)) @@ -199,7 +200,7 @@ interface appstate = do Just n -> case get (topEnv (asCtx appstate')) n of Left _ -> return () - Right expr -> putStrLn $ pretty (Def n expr) + Right expr -> putStrLn $ pprint 80 (Def n expr) putStr "> " >> hFlush stdout |