aboutsummaryrefslogtreecommitdiff
path: root/src/Haskell/Env
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haskell/Env')
-rw-r--r--src/Haskell/Env/Cmd.hs48
-rw-r--r--src/Haskell/Env/Context.hs15
2 files changed, 63 insertions, 0 deletions
diff --git a/src/Haskell/Env/Cmd.hs b/src/Haskell/Env/Cmd.hs
new file mode 100644
index 0000000..35a6542
--- /dev/null
+++ b/src/Haskell/Env/Cmd.hs
@@ -0,0 +1,48 @@
+module Haskell.Env.Cmd where
+
+import Haskell.AST
+import Haskell.Rewrite
+import Pretty
+import Util
+
+
+data Action = Action RewCmd Name
+ deriving (Show)
+
+data RewCmd = CRewrite Name
+ | CBeta
+ | CEta
+ | CCase
+ | CCaseForce
+ | CEtaCase
+ | CCaseCase
+ | CRepeat RewCmd
+ deriving (Show)
+
+instance Pretty Action where
+ pretty (Action cmd target) = Node ("action " ++ target) [pretty cmd]
+
+instance Pretty RewCmd 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]
+
+
+exprTransformer :: RewCmd -> Maybe (Expr -> Expr)
+exprTransformer = fmap (normalise .) . exprTransformer'
+
+exprTransformer' :: RewCmd -> Maybe (Expr -> Expr)
+exprTransformer' (CRewrite _) = Nothing
+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' (CRepeat (CRepeat cmd)) = exprTransformer' (CRepeat cmd)
+exprTransformer' (CRepeat cmd) = fixpoint <$> exprTransformer' cmd
diff --git a/src/Haskell/Env/Context.hs b/src/Haskell/Env/Context.hs
new file mode 100644
index 0000000..2e6b6cc
--- /dev/null
+++ b/src/Haskell/Env/Context.hs
@@ -0,0 +1,15 @@
+module Haskell.Env.Context where
+
+import Haskell.Env
+import Haskell.Env.Cmd
+
+
+data Context = Context { cStack :: [(Action, Env)], cBaseEnv :: Env }
+ deriving (Show)
+
+topEnv :: Context -> Env
+topEnv (Context [] env) = env
+topEnv (Context ((_, env):_) _) = env
+
+pushCtx :: (Action, Env) -> Context -> Context
+pushCtx pair ctx = ctx { cStack = pair : cStack ctx }