From 573967434a8b1cb14ee7de43ec11bd616cf568c6 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom.smeding@gmail.com>
Date: Tue, 9 Apr 2019 23:30:08 +0200
Subject: Organisation cleanup

---
 src/Main.hs | 96 ++++++-------------------------------------------------------
 1 file changed, 8 insertions(+), 88 deletions(-)

(limited to 'src/Main.hs')

diff --git a/src/Main.hs b/src/Main.hs
index 6dfbef5..a6d80b3 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -5,46 +5,15 @@ import Data.List
 import Data.Maybe
 import Haskell.AST
 import Haskell.Env
+import Haskell.Env.Cmd
+import Haskell.Env.Context
 import Haskell.Rewrite
 import Haskell.Parser
 import Pretty
 import System.Environment
 import System.Exit
 import System.IO
-
-
-tryEither :: Either String a -> IO a
-tryEither (Left err) = die err
-tryEither (Right x) = return x
-
-tryEither' :: Show e => Either e a -> IO a
-tryEither' (Left err) = die (show err)
-tryEither' (Right x) = return x
-
-fromRight :: Either a b -> b
-fromRight (Right x) = x
-fromRight (Left _) = error "fromRight on Left"
-
-isRight :: Either a b -> Bool
-isRight (Right _) = True
-isRight (Left _) = False
-
-while :: Monad m => a -> (a -> m (Maybe a)) -> m ()
-while val f = f val >>= \case
-    Nothing   -> return ()
-    Just val' -> while val' f
-
-whenM :: Monad m => m Bool -> m a -> m ()
-whenM b a = b >>= \b' -> if b' then void a else return ()
-
-ifM :: Monad m => m Bool -> m a -> m a -> m a
-ifM b t e = b >>= \b' -> if b' then t else e
-
-splitOn :: Eq a => a -> [a] -> [[a]]
-splitOn _   [] = [[]]
-splitOn spl (x:xs)
-    | x == spl  = [] : splitOn spl xs
-    | otherwise = let (r : rs) = splitOn spl xs in (x:r) : rs
+import Util
 
 
 usageString :: String
@@ -79,23 +48,7 @@ usageString =
 data AppState = AppState { asCtx :: Context, asFocus :: Maybe Name }
   deriving (Show)
 
-data Context = Context { cStack :: [(Action, Env)], cBaseEnv :: Env }
-  deriving (Show)
-
-data Action = Action Cmd Name
-  deriving (Show)
-
-data Cmd = CRewrite Name
-         | CBeta
-         | CEta
-         | CCase
-         | CCaseForce
-         | CEtaCase
-         | CCaseCase
-         | CRepeat Cmd
-  deriving (Show)
-
-data UserCmd = UCCmd Cmd
+data UserCmd = UCCmd RewCmd
              | CAction Action
              | CAuto
              | CRewriteAll
@@ -108,35 +61,6 @@ data UserCmd = UCCmd Cmd
              | CHelp
   deriving (Show)
 
-instance Pretty Action where
-    pretty (Action cmd target) = Node ("action " ++ target) [pretty cmd]
-
-instance Pretty Cmd where
-    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
-topEnv (Context ((_, env):_) _) = env
-
-pushCtx :: (Action, Env) -> Context -> Context
-pushCtx pair ctx = ctx { cStack = pair : cStack ctx }
-
-exprTransformer :: Cmd -> Maybe (Expr -> Expr)
-exprTransformer CBeta = Just betared
-exprTransformer CEta = Just etared
-exprTransformer CCase = Just (casered False)
-exprTransformer CCaseForce = Just (casered True)
-exprTransformer CEtaCase = Just etacase
-exprTransformer CCaseCase = Just casecase
-exprTransformer _ = Nothing
-
 ctxTransform :: Context -> Action -> (Expr -> Expr) -> Either String Context
 ctxTransform ctx act@(Action _ target) = generalCtxTransform ctx act (\env -> get env target)
 
@@ -153,14 +77,10 @@ apply ctx act@(Action cmd target) = case cmd of
             ctx act
             (\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 '" ++ pprint 80 subcmd ++ "'"
-            Just trans -> ctxTransform ctx act (fixpoint (normalise . trans))
     _ ->
-        ctxTransform ctx act (normalise . fromJust (exprTransformer cmd))
+        ctxTransform ctx act (fromJust (exprTransformer cmd))
 
-findChangingTransformer :: Expr -> Maybe Cmd
+findChangingTransformer :: Expr -> Maybe RewCmd
 findChangingTransformer expr =
     let opts = [CBeta, CEta, CCase, CEtaCase, CCaseCase]
         results = [(cmd, normalise $ fromJust (exprTransformer cmd) expr) | cmd <- opts]
@@ -302,8 +222,8 @@ main = do
 
     source <- readFile fname
     ast <- tryEither' (parseAST fname source)
-    print ast
+    -- print ast
     env0 <- tryEither (envFromAST ast)
-    print env0
+    -- print env0
 
     while (AppState (Context [] env0) Nothing) interface
-- 
cgit v1.2.3-70-g09d2