mirror of
https://github.com/rgleichman/glance.git
synced 2024-11-26 17:14:21 +03:00
Complex patterns work for pattern bind.
This commit is contained in:
Robbie Gleichman
parent
8762a6a584
commit
dddb45ebb9
14
app/Main.hs
14
app/Main.hs
@ -13,6 +13,7 @@ import Translate(translateString)
|
||||
|
||||
-- TODO Now --
|
||||
-- Destructuring pattern binds
|
||||
-- Add mode extra part to EvalContext that tells evalQName to make a binding instead of a sink.
|
||||
|
||||
-- TODO Later --
|
||||
-- Eliminate BranchIcon for the identity funciton "y x = x"
|
||||
@ -262,7 +263,14 @@ main3 = do
|
||||
]
|
||||
|
||||
patternTests = [
|
||||
"Foo x y = Foo x y"
|
||||
"y (F x) = x",
|
||||
"y = (\\(F x) -> x)",
|
||||
"y = let {g = 3; F x y = h g} in x y",
|
||||
"y = let {g = 3; F x y = g} in x y",
|
||||
"y = let F x y = g in x y",
|
||||
"F x = g x",
|
||||
"Foo (Bar x) (Baz y) = f 1 2 x y",
|
||||
"Foo x y = f 1 y x"
|
||||
]
|
||||
|
||||
letTests = [
|
||||
@ -324,8 +332,8 @@ otherTests = [
|
||||
]
|
||||
|
||||
testDecls = mconcat [
|
||||
--patternTests
|
||||
letTests
|
||||
patternTests
|
||||
,letTests
|
||||
,otherTests
|
||||
]
|
||||
|
||||
|
||||
@ -51,13 +51,23 @@ nameToString :: Language.Haskell.Exts.Name -> String
|
||||
nameToString (Ident s) = s
|
||||
nameToString (Symbol s) = s
|
||||
|
||||
-- evalPApp :: QName -> [Pat] -> String
|
||||
-- evalPApp name patterns = _
|
||||
evalPApp :: QName -> [Pat] -> State IDState (IconGraph, NameAndPort)
|
||||
evalPApp name patterns = do
|
||||
patName <- DIA.toName <$> getUniqueName "pat"
|
||||
let
|
||||
context = mempty
|
||||
evaledPatterns <- mapM evalPattern patterns
|
||||
let
|
||||
constructorName = evalQName name context
|
||||
gr = makeApplyGraph True patName constructorName evaledPatterns (length evaledPatterns)
|
||||
pure gr
|
||||
|
||||
evalPattern :: Pat -> GraphAndRef
|
||||
|
||||
evalPattern :: Pat -> State IDState GraphAndRef
|
||||
evalPattern p = case p of
|
||||
PVar n -> (mempty, Left $ nameToString n)
|
||||
--PApp name patterns -> evalPApp name patterns
|
||||
PVar n -> pure (mempty, Left $ nameToString n)
|
||||
PApp name patterns -> fmap Right <$> evalPApp name patterns
|
||||
PParen pat -> evalPattern pat
|
||||
|
||||
evalQName :: QName -> EvalContext -> (IconGraph, Reference)
|
||||
evalQName (UnQual n) context = result where
|
||||
@ -71,18 +81,20 @@ evalQOp :: QOp -> EvalContext -> (IconGraph, Reference)
|
||||
evalQOp (QVarOp n) = evalQName n
|
||||
evalQOp (QConOp n) = evalQName n
|
||||
|
||||
combineExpressions :: [((IconGraph, Reference), NameAndPort)] -> IconGraph
|
||||
combineExpressions portExpPairs = mconcat $ fmap mkGraph portExpPairs where
|
||||
combineExpressions :: Bool -> [((IconGraph, Reference), NameAndPort)] -> IconGraph
|
||||
combineExpressions inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs where
|
||||
mkGraph ((graph, ref), port) = graph <> case ref of
|
||||
Left str -> IconGraph mempty mempty mempty [(str, port)] mempty
|
||||
Left str -> if inPattern
|
||||
then IconGraph mempty mempty mempty mempty [(str, Right port)]
|
||||
else IconGraph mempty mempty mempty [(str, port)] mempty
|
||||
Right resultPort -> IconGraph mempty [Edge (resultPort, port) noEnds] mempty mempty mempty
|
||||
|
||||
makeApplyGraph :: DIA.Name -> (IconGraph, Reference) -> [(IconGraph, Reference)] -> Int -> (IconGraph, NameAndPort)
|
||||
makeApplyGraph applyIconName funVal argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1)
|
||||
makeApplyGraph :: Bool -> DIA.Name -> (IconGraph, Reference) -> [(IconGraph, Reference)] -> Int -> (IconGraph, NameAndPort)
|
||||
makeApplyGraph inPattern applyIconName funVal argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1)
|
||||
where
|
||||
argumentPorts = map (nameAndPort applyIconName) [2,3..]
|
||||
functionPort = nameAndPort applyIconName 0
|
||||
combinedGraph = combineExpressions $ zip (funVal:argVals) (functionPort:argumentPorts)
|
||||
combinedGraph = combineExpressions inPattern $ zip (funVal:argVals) (functionPort:argumentPorts)
|
||||
icons = [(applyIconName, Apply0NIcon numArgs)]
|
||||
newGraph = iconGraphFromIcons icons
|
||||
|
||||
@ -91,14 +103,14 @@ evalApp (funExp, argExps) c = do
|
||||
funVal <- evalExp c funExp
|
||||
argVals <- mapM (evalExp c) argExps
|
||||
applyIconName <- DIA.toName <$> getUniqueName "app0"
|
||||
pure $ makeApplyGraph applyIconName funVal argVals (length argExps)
|
||||
pure $ makeApplyGraph False applyIconName funVal argVals (length argExps)
|
||||
|
||||
evalInfixApp :: EvalContext -> Exp -> QOp -> Exp -> State IDState (IconGraph, NameAndPort)
|
||||
evalInfixApp c e1 op e2 = do
|
||||
argVals <- mapM (evalExp c) [e1, e2]
|
||||
applyIconName <- DIA.toName <$> getUniqueName "app0"
|
||||
let funVal = evalQOp op c
|
||||
pure $ makeApplyGraph applyIconName funVal argVals 2
|
||||
pure $ makeApplyGraph False applyIconName funVal argVals 2
|
||||
|
||||
-- TODO add test for this function
|
||||
simplifyApp :: Exp -> (Exp, [Exp])
|
||||
@ -116,7 +128,7 @@ evalIf c e1 e2 e3 = do
|
||||
let
|
||||
icons = [(guardName, GuardIcon 2)]
|
||||
combinedGraph =
|
||||
combineExpressions $ zip [e1Val, e2Val, e3Val] (map (nameAndPort guardName) [3, 2, 4])
|
||||
combineExpressions False $ zip [e1Val, e2Val, e3Val] (map (nameAndPort guardName) [3, 2, 4])
|
||||
newGraph = iconGraphFromIcons icons <> combinedGraph
|
||||
pure (newGraph, NameAndPort guardName (Just 0))
|
||||
|
||||
@ -140,7 +152,7 @@ evalGuardedRhss c rhss = do
|
||||
(bools, exps) = unzip evaledRhss
|
||||
expsWithPorts = zip exps $ map (nameAndPort guardName) [2,4..]
|
||||
boolsWithPorts = zip bools $ map (nameAndPort guardName) [3,5..]
|
||||
combindedGraph = combineExpressions $ expsWithPorts <> boolsWithPorts
|
||||
combindedGraph = combineExpressions False $ expsWithPorts <> boolsWithPorts
|
||||
icons = [(guardName, GuardIcon (length rhss))]
|
||||
newGraph = iconGraphFromIcons icons <> combindedGraph
|
||||
pure (newGraph, NameAndPort guardName (Just 0))
|
||||
@ -167,11 +179,12 @@ evalLit (Exts.PrimChar x) = makeLiteral x
|
||||
evalLit (Exts.PrimString x) = makeLiteral x
|
||||
|
||||
namesInPattern :: GraphAndRef -> [String]
|
||||
namesInPattern (gr, Left str) = [str]
|
||||
-- TODO: this case getBoundNamesFromPattern (gr, Right p) = _
|
||||
namesInPattern (_, Left str) = [str]
|
||||
namesInPattern (IconGraph _ _ _ _ bindings, Right _) = fmap fst bindings
|
||||
|
||||
getBoundVarName :: Decl -> [String]
|
||||
getBoundVarName (PatBind _ pat _ _) = namesInPattern $ evalPattern pat
|
||||
-- TODO Should evalState be used here?
|
||||
getBoundVarName (PatBind _ pat _ _) = namesInPattern $ evalState (evalPattern pat) initialIdState
|
||||
getBoundVarName (FunBind [Match _ name _ _ _ _]) = [nameToString name]
|
||||
|
||||
--TODO: Should this call makeEdges?
|
||||
@ -230,6 +243,7 @@ evalLet context binds e = evalGeneralLet (`evalExp` e) context binds
|
||||
evalExp :: EvalContext -> Exp -> State IDState (IconGraph, Reference)
|
||||
evalExp c x = case x of
|
||||
Var n -> pure $ evalQName n c
|
||||
Con n -> pure $ 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 (simplifyApp e) c
|
||||
@ -256,22 +270,24 @@ evalRhs (UnGuardedRhs e) c = evalExp c e
|
||||
evalRhs (GuardedRhss rhss) c = fmap Right <$> evalGuardedRhss c rhss
|
||||
|
||||
evalPatBind :: EvalContext -> Decl -> State IDState IconGraph
|
||||
evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = helper <$> evaledRhs
|
||||
where
|
||||
patName = evalPattern pat
|
||||
patternNames = namesInPattern $ evalPattern pat
|
||||
evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
|
||||
patternNames <- printSelf . namesInPattern <$> evalPattern pat
|
||||
let
|
||||
rhsContext = patternNames <> c
|
||||
evaledRhs = case maybeWhereBinds of
|
||||
Nothing -> evalRhs rhs rhsContext
|
||||
Just b -> evalGeneralLet (evalRhs rhs) rhsContext b
|
||||
|
||||
helper (rhsGraph, rhsRef) = makeEdges (gr <> rhsGraph)
|
||||
where
|
||||
bindings = case patName of
|
||||
(_, Left s) -> [(s, rhsRef)]
|
||||
-- TODO (_ -> _) case. If the patName is not a ref, than add those bindings.
|
||||
gr = IconGraph mempty mempty mempty mempty bindings
|
||||
(rhsGraph, rhsRef) <- case maybeWhereBinds of
|
||||
Nothing -> evalRhs rhs rhsContext
|
||||
Just b -> evalGeneralLet (evalRhs rhs) rhsContext b
|
||||
|
||||
(patGraph, patRef) <- evalPattern pat
|
||||
let
|
||||
(newEdges, newSinks, bindings) = case patRef of
|
||||
(Left s) -> (mempty, mempty, [(s, rhsRef)])
|
||||
(Right patPort) -> case rhsRef of
|
||||
(Left rhsStr) -> (mempty, [(rhsStr, patPort)], mempty)
|
||||
-- TODO: This edge should be special to indicate that one side is a pattern.
|
||||
(Right rhsPort) -> ([Edge (rhsPort, patPort) noEnds], mempty, mempty)
|
||||
gr = IconGraph mempty newEdges mempty newSinks bindings
|
||||
pure .printSelf. makeEdges $ (gr <> rhsGraph <> patGraph)
|
||||
|
||||
iconGraphToDrawing :: IconGraph -> Drawing
|
||||
iconGraphToDrawing (IconGraph icons edges subDrawings _ _) = Drawing icons edges subDrawings
|
||||
@ -283,7 +299,7 @@ processPatterns lambdaName patterns extraVars =
|
||||
where
|
||||
lambdaPorts = map (nameAndPort lambdaName) [0,1..]
|
||||
-- TODO this is wrong and must be rewritten for more complex patterns. (perhaps use makeEdges)
|
||||
patternStringMap = extraVars <> zip (map (head . namesInPattern . evalPattern) patterns) lambdaPorts
|
||||
patternStringMap = extraVars <> zip (map (head . namesInPattern. (`evalState` initialIdState) .evalPattern) patterns) lambdaPorts
|
||||
patternStrings = map fst patternStringMap
|
||||
numParameters = length patterns
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user