mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +03:00
Add more to SimplifySyntax.
This commit is contained in:
parent
29f03483f7
commit
3b55075fd5
@ -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
|
||||
|
@ -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 =>
|
||||
|
Loading…
Reference in New Issue
Block a user