rgleichman/glance
1
1
Fork 0
mirror of https://github.com/rgleichman/glance.git synced 2024-11-30 05:47:46 +03:00
Code Issues Projects Releases Wiki Activity

Refactor matches/cases in Translate.hs.

Browse Source
This commit is contained in:
Robbie Gleichman 2016-12-13 13:40:23 -08:00
parent aa5aa82801
commit 4252717f61
1 changed files with 25 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
app/Translate.hs
View File

@ -63,14 +63,14 @@ qNameToString (Special Cons) = "(:)"
qNameToString (Special UnboxedSingleCon) = "(# #)" qNameToString (Special UnboxedSingleCon) = "(# #)"
evalPApp :: QName -> [Pat] -> State IDState (SyntaxGraph, NameAndPort) evalPApp :: QName -> [Pat] -> State IDState (SyntaxGraph, NameAndPort)
evalPApp name [] = makeBox $ qNameToString name evalPApp name patterns = case patterns of
evalPApp name patterns = do [] -> makeBox constructorName
_ -> do
patName <- getUniqueName "pat" patName <- getUniqueName "pat"
evaledPatterns <- mapM evalPattern patterns evaledPatterns <- mapM evalPattern patterns
let pure $ makePatternGraph patName constructorName evaledPatterns (length evaledPatterns)
where
constructorName = qNameToString name constructorName = qNameToString name
gr = makePatternGraph patName constructorName evaledPatterns (length evaledPatterns)
pure gr
evalPLit :: Exts.Sign -> Exts.Literal -> State IDState (SyntaxGraph, NameAndPort) evalPLit :: Exts.Sign -> Exts.Literal -> State IDState (SyntaxGraph, NameAndPort)
evalPLit Exts.Signless l = evalLit l evalPLit Exts.Signless l = evalLit l
@ -109,9 +109,13 @@ strToGraphRef c str = fmap mapper (makeBox str) where
else fmap Right gr else fmap Right gr
evalQName :: QName -> EvalContext -> State IDState (SyntaxGraph, Reference) evalQName :: QName -> EvalContext -> State IDState (SyntaxGraph, Reference)
evalQName qName@(UnQual _) c = strToGraphRef c (qNameToString qName) evalQName qName c = case qName of
evalQName qName@(Qual _ _) c = strToGraphRef c (qNameToString qName) UnQual _ -> graphRef
evalQName qName _ = fmap Right <$> makeBox (qNameToString qName) Qual _ _ -> graphRef
_ -> fmap Right <$> makeBox qNameString
where
qNameString = qNameToString qName
graphRef = strToGraphRef c qNameString
-- evalQOp :: QOp -> EvalContext -> State IDState (SyntaxGraph, Reference) -- evalQOp :: QOp -> EvalContext -> State IDState (SyntaxGraph, Reference)
-- evalQOp (QVarOp n) = evalQName n -- evalQOp (QVarOp n) = evalQName n
@ -199,10 +203,15 @@ simplifyCompose e = case removeParen e of
x -> [x] x -> [x]
evalInfixApp :: EvalContext -> Exp -> QOp -> Exp -> State IDState (SyntaxGraph, Reference) evalInfixApp :: EvalContext -> Exp -> QOp -> Exp -> State IDState (SyntaxGraph, Reference)
evalInfixApp c e1 (QVarOp (UnQual (Symbol "$"))) e2 = evalExp c (App e1 e2) evalInfixApp c e1 op e2 = case op of
evalInfixApp c e1 (QVarOp (UnQual (Symbol "<$>"))) e2 = evalExp c $ App (App (makeVarExp "fmap") e1) e2 QVarOp (UnQual (Symbol sym)) -> case sym of
evalInfixApp c e1 (QVarOp (UnQual (Symbol "."))) e2 = fmap Right <$> evalCompose c (e1 : simplifyCompose e2) "$" -> evalExp c (App e1 e2)
evalInfixApp c e1 op e2 = evalExp c (App (App (qOpToExp op) e1) e2) "<$>" -> evalExp c $ App (App (makeVarExp "fmap") e1) e2
"." -> fmap Right <$> evalCompose c (e1 : simplifyCompose e2)
_ -> defaultCase
_ -> defaultCase
where
defaultCase = evalExp c $ App (App (qOpToExp op) e1) e2
scoreExpressions :: Exp -> Exp -> (Int, Int) scoreExpressions :: Exp -> Exp -> (Int, Int)
scoreExpressions exp1 exp2 = (appScore, compScore) where scoreExpressions exp1 exp2 = (appScore, compScore) where
@ -574,9 +583,8 @@ evalMatches _ [] = pure mempty
evalMatches c (firstMatch:restOfMatches) = matchesToCase firstMatch restOfMatches >>= evalMatch c evalMatches c (firstMatch:restOfMatches) = matchesToCase firstMatch restOfMatches >>= evalMatch c
evalDecl :: EvalContext -> Decl -> State IDState SyntaxGraph evalDecl :: EvalContext -> Decl -> State IDState SyntaxGraph
evalDecl c d = evaluatedDecl where evalDecl c d = case d of
evaluatedDecl = case d of PatBind _ _ _ _ -> evalPatBind c d
pat@(PatBind _ _ _ _) -> evalPatBind c pat
FunBind matches -> evalMatches c matches FunBind matches -> evalMatches c matches
--TODO: Add other cases here --TODO: Add other cases here
_ -> pure mempty _ -> pure mempty