mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +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 qualified Language.Haskell.Exts as Exts
|
||||||
|
|
||||||
import Translate(qOpToExp)
|
import Translate(qOpToExp, qNameToString)
|
||||||
-- A simplified Haskell syntax tree
|
-- A simplified Haskell syntax tree
|
||||||
|
|
||||||
-- rhs is now SimpExp
|
-- rhs is now SimpExp
|
||||||
|
|
||||||
-- A simplified Haskell expression.
|
-- A simplified Haskell expression.
|
||||||
data SimpExp l =
|
data SimpExp l =
|
||||||
SeName l (Exts.QName l)
|
SeName l String
|
||||||
| SeLit l (Exts.Literal l)
|
| SeLit l (Exts.Literal l)
|
||||||
| SeApp l
|
| SeApp l
|
||||||
(SimpExp l) -- function
|
(SimpExp l) -- function
|
||||||
@ -41,7 +41,8 @@ data SimpPat l =
|
|||||||
| SpApp l (Exts.QName l) [SimpPat l]
|
| SpApp l (Exts.QName l) [SimpPat l]
|
||||||
| SpAsPat l (Exts.Name 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
|
infixAppToSeApp l e1 op e2 = case op of
|
||||||
Exts.QVarOp _ (Exts.UnQual _ (Exts.Symbol _ sym)) -> case sym of
|
Exts.QVarOp _ (Exts.UnQual _ (Exts.Symbol _ sym)) -> case sym of
|
||||||
"$" -> hsExpToSimpExp (Exts.App l e1 e2)
|
"$" -> hsExpToSimpExp (Exts.App l e1 e2)
|
||||||
@ -53,10 +54,34 @@ infixAppToSeApp l e1 op e2 = case op of
|
|||||||
where
|
where
|
||||||
defaultCase = hsExpToSimpExp $ Exts.App l (Exts.App l (qOpToExp op) e1) e2
|
defaultCase = hsExpToSimpExp $ Exts.App l (Exts.App l (qOpToExp op) e1) e2
|
||||||
|
|
||||||
hsExpToSimpExp :: Exts.Exp a -> SimpExp a
|
hsPatToSimpPat :: Exts.Pat a -> SimpPat a
|
||||||
hsExpToSimpExp e = case e of
|
hsPatToSimpPat = undefined
|
||||||
Exts.Var l n -> SeName l n
|
|
||||||
Exts.Con l n -> SeName l n
|
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.Lit l n -> SeLit l n
|
||||||
Exts.InfixApp l e1 op e2 -> infixAppToSeApp l e1 op e2
|
Exts.InfixApp l e1 op e2 -> infixAppToSeApp l e1 op e2
|
||||||
Exts.App l f arg -> SeApp l (hsExpToSimpExp f) (hsExpToSimpExp arg)
|
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,
|
translateStringToSyntaxGraph,
|
||||||
translateStringToCollapsedGraphAndDecl,
|
translateStringToCollapsedGraphAndDecl,
|
||||||
translateModuleToCollapsedGraphs,
|
translateModuleToCollapsedGraphs,
|
||||||
qOpToExp
|
qOpToExp,
|
||||||
|
qNameToString
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Diagrams.Prelude((<>))
|
import Diagrams.Prelude((<>))
|
||||||
@ -495,7 +496,7 @@ evalBinds c (BDecls _ decls) =
|
|||||||
boundNames = concatMap getBoundVarName decls
|
boundNames = concatMap getBoundVarName decls
|
||||||
augmentedContext = boundNames <> c
|
augmentedContext = boundNames <> c
|
||||||
in
|
in
|
||||||
((,augmentedContext) . mconcat) <$> mapM (evalDecl augmentedContext) decls
|
(,augmentedContext) . mconcat <$> mapM (evalDecl augmentedContext) decls
|
||||||
evalBinds _ binds = error $ "Unsupported syntax in evalBinds: " <> show binds
|
evalBinds _ binds = error $ "Unsupported syntax in evalBinds: " <> show binds
|
||||||
|
|
||||||
evalGeneralLet :: Show l =>
|
evalGeneralLet :: Show l =>
|
||||||
|
Loading…
Reference in New Issue
Block a user