mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Add NegExp, List patterns, changes for bootstrapping.
This commit is contained in:
parent
1de078336e
commit
5818f286e6
22
app/Main.hs
22
app/Main.hs
@ -29,6 +29,7 @@ import Translate(translateString, drawingsFromModule)
|
||||
-- Consider using seperate parameter icons in functions.
|
||||
-- Make constructors in patterns PatternColor.
|
||||
-- Add function name and type to LambdaIcons.
|
||||
-- Add proper RecConstr, and RecUpdate support.
|
||||
-- Let each bool, value pair in Guard icon be flipped to reduce line crossings. Do the same for case.
|
||||
-- Add text field to Apply. Also redraw text and icon when it is rotated so that the characters stay oriented.
|
||||
-- Eliminate BranchIcon in Alts.
|
||||
@ -286,6 +287,12 @@ specialTests = [
|
||||
"yyyyy = fffff xxxxx"
|
||||
]
|
||||
|
||||
negateTests = [
|
||||
"y = -1",
|
||||
"y = -1/2",
|
||||
"y = -x"
|
||||
]
|
||||
|
||||
doTests = [
|
||||
"y = do {x1}",
|
||||
"y = do {x1; x2}",
|
||||
@ -313,7 +320,11 @@ listTests = [
|
||||
"y = []",
|
||||
"y = [1]",
|
||||
"y = [1,2]",
|
||||
"y = [1,2,3]"
|
||||
"y = [1,2,3]",
|
||||
"[x] = 1",
|
||||
"[x, y] = 2",
|
||||
"[x, y, z] = 3"
|
||||
-- TODO: Add this test "(x:y) = 3"
|
||||
]
|
||||
|
||||
caseTests = [
|
||||
@ -348,7 +359,8 @@ patternTests = [
|
||||
"y = let {t@(_,_) = (3,4)} in t + 3",
|
||||
"y = let {(x, y) = (1,2)} in x + y",
|
||||
-- TODO: Fix so that lines between patterns are Pattern Color.
|
||||
"y = let {(x, y) = (1,2); (z, w) = x; (m, g) = y} in foo x y z w m g"
|
||||
"y = let {(x, y) = (1,2); (z, w) = x; (m, g) = y} in foo x y z w m g",
|
||||
"(x:y) = 2"
|
||||
]
|
||||
|
||||
lambdaTests = [
|
||||
@ -423,7 +435,8 @@ otherTests = [
|
||||
]
|
||||
|
||||
testDecls = mconcat [
|
||||
doTests
|
||||
negateTests
|
||||
,doTests
|
||||
,enumTests
|
||||
,caseTests
|
||||
,lambdaTests
|
||||
@ -431,7 +444,7 @@ testDecls = mconcat [
|
||||
,patternTests
|
||||
,specialTests
|
||||
,tupleTests
|
||||
, listTests
|
||||
,listTests
|
||||
,letTests
|
||||
,operatorTests
|
||||
,otherTests
|
||||
@ -464,7 +477,6 @@ main5 :: IO ()
|
||||
main5 = do
|
||||
parseResult <- Exts.parseFileWithExts [Exts.EnableExtension Exts.MultiParamTypeClasses, Exts.EnableExtension Exts.FlexibleContexts]
|
||||
"./test/test_translate.hs"
|
||||
--"./app/Icons.hs"
|
||||
let
|
||||
parsedModule = Exts.fromParseResult parseResult
|
||||
drawings = drawingsFromModule parsedModule
|
||||
|
@ -91,7 +91,8 @@ getArrowOpts (t, h) opts = arrowOptions
|
||||
with & arrowHead .~ noHead
|
||||
& arrowTail .~ noTail
|
||||
& lengths .~ global 0.75
|
||||
& shaftStyle %~ lwG defaultLineWidth . lc (shaftColor colorScheme)
|
||||
-- this parenthesis "%~ (lwG .. colorScheme))" is necessary for haskell-src-exts to parse the file.
|
||||
& shaftStyle %~ (lwG defaultLineWidth . lc (shaftColor colorScheme))
|
||||
& lookupTail t & lookupHead h
|
||||
|
||||
-- | Given an Edge, return a transformation on Diagrams that will draw a line.
|
||||
|
@ -70,17 +70,20 @@ evalPAsPat n p = do
|
||||
(evaledPatGraph, evaledPatRef) <- evalPattern p
|
||||
let
|
||||
newBind = [(nameToString n, evaledPatRef)]
|
||||
newGraph = mempty{igBindings = newBind}
|
||||
newGraph = IconGraph mempty mempty mempty mempty newBind
|
||||
pure (newGraph <> evaledPatGraph, evaledPatRef)
|
||||
|
||||
evalPattern :: Pat -> State IDState GraphAndRef
|
||||
evalPattern p = case p of
|
||||
PVar n -> pure (mempty, Left $ nameToString n)
|
||||
PLit s l -> fmap Right <$> evalPLit s l
|
||||
PInfixApp p1 qName p2 -> evalPattern (PApp qName [p1, p2])
|
||||
PApp name patterns -> fmap Right <$> evalPApp name patterns
|
||||
-- TODO special tuple handling.
|
||||
PTuple _ patterns ->
|
||||
fmap Right <$> evalPApp (Exts.UnQual . Ident . nTupleString . length $ patterns) patterns
|
||||
PList patterns ->
|
||||
fmap Right <$> evalPApp (Exts.UnQual . Ident . nListString . length $ patterns) patterns
|
||||
PParen pat -> evalPattern pat
|
||||
PAsPat n subPat -> evalPAsPat n subPat
|
||||
PWildCard -> fmap Right <$> makeBox "_"
|
||||
@ -200,7 +203,7 @@ getBoundVarName :: Decl -> [String]
|
||||
getBoundVarName (PatBind _ pat _ _) = namesInPattern $ evalState (evalPattern pat) initialIdState
|
||||
getBoundVarName (FunBind (Match _ name _ _ _ _:_)) = [nameToString name]
|
||||
-- TODO: Other cases
|
||||
getBoundVarName TypeSig{} = []
|
||||
getBoundVarName (TypeSig _ _ _) = []
|
||||
getBoundVarName decl = error $ "getBoundVarName: No pattern in case for " ++ show decl
|
||||
|
||||
--TODO: Should this call makeEdges?
|
||||
@ -279,9 +282,11 @@ evalTuple c exps = do
|
||||
applyIconName <- DIA.toName <$> getUniqueName "tupleApp"
|
||||
pure $ makeApplyGraph False applyIconName (fmap Right funVal) argVals (length exps)
|
||||
|
||||
makeVarExp = Var . UnQual . Ident
|
||||
|
||||
evalListExp :: EvalContext -> [Exp] -> State IDState (IconGraph, NameAndPort)
|
||||
evalListExp c [] = makeBox "[]"
|
||||
evalListExp c exps = evalApp c (Var . UnQual . Ident . nListString . length $ exps, exps)
|
||||
evalListExp c exps = evalApp c (makeVarExp . nListString . length $ exps, exps)
|
||||
|
||||
evalLeftSection :: EvalContext -> Exp -> QOp -> State IDState (IconGraph, NameAndPort)
|
||||
evalLeftSection c e op = evalApp c (qOpToExp op, [e])
|
||||
@ -309,13 +314,18 @@ desugarDo (Generator srcLoc pat e : stmts) =
|
||||
InfixApp e (makeQVarOp ">>=") (Lambda srcLoc [pat] (desugarDo stmts))
|
||||
desugarDo (LetStmt binds : stmts) = Let binds (desugarDo stmts)
|
||||
|
||||
-- TODO: Finish evalRecConstr
|
||||
evalRecConstr :: EvalContext -> QName -> [Exts.FieldUpdate] -> State IDState (IconGraph, Reference)
|
||||
evalRecConstr c qName updates = evalQName qName c
|
||||
|
||||
evalExp :: EvalContext -> Exp -> State IDState (IconGraph, Reference)
|
||||
evalExp c x = case x of
|
||||
Var n -> evalQName n c
|
||||
Con n -> evalQName n c
|
||||
Lit l -> fmap Right <$> evalLit l
|
||||
InfixApp e1 op e2 -> fmap Right <$> evalInfixApp c e1 op e2
|
||||
e@App{} -> fmap Right <$> evalApp c (simplifyApp e)
|
||||
e@(App _ _) -> fmap Right <$> evalApp c (simplifyApp e)
|
||||
NegApp e -> evalExp c (App (makeVarExp "negate") e)
|
||||
Lambda _ patterns e -> fmap Right <$> evalLambda c patterns e
|
||||
Let bs e -> evalLet c bs e
|
||||
If e1 e2 e3 -> fmap Right <$> evalIf c e1 e2 e3
|
||||
@ -327,10 +337,15 @@ evalExp c x = case x of
|
||||
Paren e -> evalExp c e
|
||||
LeftSection e op -> fmap Right <$> evalLeftSection c e op
|
||||
RightSection op e -> fmap Right <$> evalRightSection c op e
|
||||
RecConstr n updates -> evalRecConstr c n updates
|
||||
-- TODO: Do RecUpdate correcly
|
||||
RecUpdate e updates -> evalExp c e
|
||||
EnumFrom e -> evalEnums c "enumFrom" [e]
|
||||
EnumFromTo e1 e2 -> evalEnums c "enumFromTo" [e1, e2]
|
||||
EnumFromThen e1 e2 -> evalEnums c "enumFromThen" [e1, e2]
|
||||
EnumFromThenTo e1 e2 e3 -> evalEnums c "enumFromThenTo" [e1, e2, e3]
|
||||
-- TODO: Add the type signiture to ExpTypeSig.
|
||||
ExpTypeSig _ e _ -> evalExp c e
|
||||
-- TODO: Add other cases
|
||||
_ -> error $ "evalExp: No pattern in case for " ++ show x
|
||||
|
||||
@ -452,7 +467,7 @@ evalMatches c (firstMatch:restOfMatches) = matchesToCase firstMatch restOfMatche
|
||||
evalDecl :: EvalContext -> Decl -> State IDState IconGraph
|
||||
evalDecl c d = evaluatedDecl where
|
||||
evaluatedDecl = case d of
|
||||
pat@PatBind{} -> evalPatBind c pat
|
||||
pat@(PatBind _ _ _ _) -> evalPatBind c pat
|
||||
FunBind matches -> evalMatches c matches
|
||||
--TODO: Add other cases here
|
||||
_ -> pure mempty
|
||||
|
Loading…
Reference in New Issue
Block a user