aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorTom Smeding <tom.smeding@gmail.com>2019-04-08 22:57:10 +0200
committerTom Smeding <tom.smeding@gmail.com>2019-04-08 22:57:10 +0200
commit8f742dc39085ebd15848ab32662239e8562a430c (patch)
treeb71283d400713d7d96095b715c8ea608c9d84c9a /src
parent57ac7ed93d048397b36e53d50db6d328e31bd2cc (diff)
Add rewall command
Diffstat (limited to 'src')
-rw-r--r--src/Haskell/AST.hs30
-rw-r--r--src/Main.hs29
2 files changed, 50 insertions, 9 deletions
diff --git a/src/Haskell/AST.hs b/src/Haskell/AST.hs
index 1e181e2..f8b5c72 100644
--- a/src/Haskell/AST.hs
+++ b/src/Haskell/AST.hs
@@ -105,7 +105,29 @@ instance Pretty Inst where
pretty (Inst n t ds) = Node ("instance " ++ n ++ " " ++ pprintOneline t ++ " where") [Bracket "{" "}" ";" (map pretty ds)]
-mapInit :: (a -> a) -> [a] -> [a]
-mapInit _ [] = []
-mapInit _ [x] = [x]
-mapInit f (x:y:zs) = f x : mapInit f (y:zs)
+class AllRefs a where
+ allRefs :: a -> [Name]
+
+instance AllRefs AST where
+ allRefs (AST tops) = nub $ concatMap allRefs tops
+
+instance AllRefs Toplevel where
+ allRefs (TopDef def) = allRefs def
+ allRefs (TopDecl _) = []
+ allRefs (TopData _) = []
+ allRefs (TopClass _) = []
+ allRefs (TopInst inst) = allRefs inst
+
+instance AllRefs Def where
+ allRefs (Def _ e) = allRefs e
+
+instance AllRefs Expr where
+ allRefs (App e es) = nub $ concatMap allRefs (e : es)
+ allRefs (Ref n) = [n]
+ allRefs (Num _) = []
+ allRefs (Tup es) = nub $ concatMap allRefs es
+ allRefs (Lam ns e) = allRefs e \\ ns
+ allRefs (Case e pairs) = nub $ allRefs e ++ concatMap (allRefs . snd) pairs
+
+instance AllRefs Inst where
+ allRefs (Inst _ _ ds) = nub $ concatMap allRefs ds
diff --git a/src/Main.hs b/src/Main.hs
index 460e2ab..6dfbef5 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -23,7 +23,11 @@ tryEither' (Right x) = return x
fromRight :: Either a b -> b
fromRight (Right x) = x
-fromRight _ = error "fromRight on Left"
+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
@@ -54,6 +58,7 @@ usageString =
\ log -- Print list of commands that reproduces current environment\n\
\ help -- Show this help\n\
\ auto -- Try to simplify the currently focused expression as far as possible\n\
+ \ rewall -- Rewrite as much as possible, but each name at most once\n\
\\n\
\\x1B[1mExpression rewrite commands\x1B[0m\n\
\These commands operate on the currently-focused expression.\n\
@@ -93,6 +98,7 @@ data Cmd = CRewrite Name
data UserCmd = UCCmd Cmd
| CAction Action
| CAuto
+ | CRewriteAll
| CExit
| CUndo
| CShowEnv
@@ -179,12 +185,24 @@ applyUserCmd appstate = \case
Just focus ->
let nextStep ctx = case findChangingTransformer (fromRight (get (topEnv ctx) focus)) of
Nothing -> Right ctx
- Just cmd -> case ctxTransform ctx (Action cmd focus) (normalise . fromJust (exprTransformer cmd)) of
+ Just cmd -> case apply ctx (Action cmd focus) of
Left err -> Left err
Right ctx' -> nextStep ctx'
- in case nextStep (asCtx appstate) of
- Left err -> return (Left err)
- Right ctx -> return (Right (Just appstate { asCtx = ctx }))
+ in return $ fmap (\ctx -> Just appstate { asCtx = ctx }) $ nextStep (asCtx appstate)
+ CRewriteAll ->
+ case asFocus appstate of
+ Nothing -> return (Left "No focus set")
+ Just focus ->
+ let nextStep ctx done =
+ let orig = fromRight (get (topEnv ctx) focus)
+ in case filter (isRight . get (topEnv ctx)) $ allRefs orig \\ done of
+ [] -> Right ctx
+ (name:_) -> case apply ctx (Action (CRewrite name) focus) of
+ Left err -> Left ("Error rewriting '" ++ name ++ "': " ++ err)
+ Right ctx' ->
+ let newexpr = fromRight (get (topEnv ctx') focus)
+ in nextStep (if newexpr /= orig then ctx' else ctx) (name : done)
+ in return $ fmap (\ctx -> Just appstate { asCtx = ctx }) $ nextStep (asCtx appstate) []
CExit ->
return (Right Nothing)
CUndo ->
@@ -262,6 +280,7 @@ parseCmd ["focus", name] = Right (CFocus name)
parseCmd ["log"] = Right CLog
parseCmd ["help"] = Right CHelp
parseCmd ["auto"] = Right CAuto
+parseCmd ["rewall"] = Right CRewriteAll
parseCmd ["rew", func] = Right (UCCmd (CRewrite func))
parseCmd ["beta"] = Right (UCCmd CBeta)
parseCmd ["eta"] = Right (UCCmd CEta)