diff --git a/app/SimplifySyntax.hs b/app/SimplifySyntax.hs index c459f37..4525a84 100644 --- a/app/SimplifySyntax.hs +++ b/app/SimplifySyntax.hs @@ -2,14 +2,14 @@ module SimplifySyntax where import qualified Language.Haskell.Exts as Exts -import Translate(qOpToExp) +import Translate(qOpToExp, qNameToString) -- A simplified Haskell syntax tree -- rhs is now SimpExp -- A simplified Haskell expression. data SimpExp l = - SeName l (Exts.QName l) + SeName l String | SeLit l (Exts.Literal l) | SeApp l (SimpExp l) -- function @@ -41,7 +41,8 @@ data SimpPat l = | SpApp l (Exts.QName l) [SimpPat l] | SpAsPat l (Exts.Name l) (SimpPat l) -infixAppToSeApp :: a -> Exts.Exp a -> Exts.QOp a -> Exts.Exp a -> SimpExp a +infixAppToSeApp :: Show a => + a -> Exts.Exp a -> Exts.QOp a -> Exts.Exp a -> SimpExp a infixAppToSeApp l e1 op e2 = case op of Exts.QVarOp _ (Exts.UnQual _ (Exts.Symbol _ sym)) -> case sym of "$" -> hsExpToSimpExp (Exts.App l e1 e2) @@ -53,10 +54,34 @@ infixAppToSeApp l e1 op e2 = case op of where defaultCase = hsExpToSimpExp $ Exts.App l (Exts.App l (qOpToExp op) e1) e2 -hsExpToSimpExp :: Exts.Exp a -> SimpExp a -hsExpToSimpExp e = case e of - Exts.Var l n -> SeName l n - Exts.Con l n -> SeName l n +hsPatToSimpPat :: Exts.Pat a -> SimpPat a +hsPatToSimpPat = undefined + +hsBindsToDecls :: Exts.Binds a -> [SimpDecl a] +hsBindsToDecls = undefined + +hsAltToSimpAlt :: Exts.Alt a -> SimpAlt a +hsAltToSimpAlt = undefined + +ifToGuard :: a -> SimpExp a -> SimpExp a -> SimpExp a -> SimpExp a +ifToGuard l e1 e2 e3 + = SeGuard l [SelectorAndVal{svSelector=e1, svVal=e2} + , SelectorAndVal{svSelector=otherwiseExp, svVal=e3}] + where + otherwiseExp = SeName l "otherwise" + +hsExpToSimpExp :: Show a => Exts.Exp a -> SimpExp a +hsExpToSimpExp x = case x of + Exts.Var l n -> SeName l (qNameToString n) + Exts.Con l n -> SeName l (qNameToString n) Exts.Lit l n -> SeLit l n Exts.InfixApp l e1 op e2 -> infixAppToSeApp l e1 op e2 Exts.App l f arg -> SeApp l (hsExpToSimpExp f) (hsExpToSimpExp arg) + Exts.Lambda l patterns e + -> SeLambda l (fmap hsPatToSimpPat patterns) (hsExpToSimpExp e) + Exts.Let l bs e -> SeLet l (hsBindsToDecls bs) (hsExpToSimpExp e) + Exts.If l e1 e2 e3 + -> ifToGuard l (hsExpToSimpExp e1) (hsExpToSimpExp e2) (hsExpToSimpExp e3) + Exts.Case l e alts -> SeCase l (hsExpToSimpExp e) (fmap hsAltToSimpAlt alts) + Exts.Paren _ e -> hsExpToSimpExp e + _ -> error $ "Unsupported syntax in hsExpToSimpExp: " ++ show x diff --git a/app/Translate.hs b/app/Translate.hs index 472985d..593e207 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -3,7 +3,8 @@ module Translate( translateStringToSyntaxGraph, translateStringToCollapsedGraphAndDecl, translateModuleToCollapsedGraphs, - qOpToExp + qOpToExp, + qNameToString ) where import Diagrams.Prelude((<>)) @@ -495,7 +496,7 @@ evalBinds c (BDecls _ decls) = boundNames = concatMap getBoundVarName decls augmentedContext = boundNames <> c in - ((,augmentedContext) . mconcat) <$> mapM (evalDecl augmentedContext) decls + (,augmentedContext) . mconcat <$> mapM (evalDecl augmentedContext) decls evalBinds _ binds = error $ "Unsupported syntax in evalBinds: " <> show binds evalGeneralLet :: Show l =>