Add NegExp, List patterns, changes for bootstrapping.

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

app/Rendering.hs

@@ -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.

app/Translate.hs

@@ -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