mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-17 02:40:28 +03:00
Fix @ (as patterns).
This commit is contained in:
parent
e876c6c401
commit
c426ff422a
@ -11,7 +11,7 @@ import Data.Maybe(catMaybes)
|
||||
import Control.Monad(replicateM)
|
||||
import Control.Monad.State(State, evalState)
|
||||
import Data.Either(partitionEithers)
|
||||
import Data.List(unzip5, unzip4, partition, intercalate)
|
||||
import Data.List(unzip5, partition, intercalate)
|
||||
import qualified Language.Haskell.Exts as Exts
|
||||
import Language.Haskell.Exts(Decl(..), parseDecl, Name(..), Pat(..), Rhs(..),
|
||||
Exp(..), QName(..), fromParseResult, Match(..), QOp(..), GuardedRhs(..),
|
||||
@ -44,6 +44,15 @@ makeVarExp = Var . UnQual . Ident
|
||||
makeQVarOp :: String -> QOp
|
||||
makeQVarOp = QVarOp . UnQual . Ident
|
||||
|
||||
bindsToSyntaxGraph :: [(String, Reference)] -> SyntaxGraph
|
||||
bindsToSyntaxGraph binds = SyntaxGraph mempty mempty mempty binds mempty
|
||||
|
||||
makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph
|
||||
makeAsBindGraph ref asNames = bindsToSyntaxGraph $ catMaybes $ fmap makeBind asNames where
|
||||
makeBind mName = case mName of
|
||||
Nothing -> Nothing
|
||||
Just asName -> Just (asName, ref)
|
||||
|
||||
-- END HELPER FUNCTIONS --
|
||||
|
||||
nameToString :: Language.Haskell.Exts.Name -> String
|
||||
@ -75,28 +84,31 @@ evalPLit :: Exts.Sign -> Exts.Literal -> State IDState (SyntaxGraph, NameAndPort
|
||||
evalPLit Exts.Signless l = evalLit l
|
||||
evalPLit Exts.Negative l = makeBox ('-' : showLiteral l)
|
||||
|
||||
evalPAsPat :: Name -> Pat -> State IDState GraphAndRef
|
||||
evalPAsPat :: Name -> Pat -> State IDState (GraphAndRef, Maybe String)
|
||||
evalPAsPat n p = do
|
||||
(evaledPatGraph, evaledPatRef) <- evalPattern p
|
||||
((evaledPatGraph, evaledPatRef), mInnerName) <- evalPattern p
|
||||
let
|
||||
newBind = [(nameToString n, evaledPatRef)]
|
||||
newGraph = SyntaxGraph mempty mempty mempty newBind mempty
|
||||
pure (newGraph <> evaledPatGraph, evaledPatRef)
|
||||
outerName = nameToString n
|
||||
asBindGraph = makeAsBindGraph (Left outerName) [mInnerName]
|
||||
pure ((asBindGraph <> evaledPatGraph, evaledPatRef), Just outerName)
|
||||
|
||||
evalPattern :: Pat -> State IDState GraphAndRef
|
||||
makePatternResult :: Functor f => f (t, b) -> f ((t, Either a b), Maybe a)
|
||||
makePatternResult = fmap (\(graph, namePort) -> ((graph, Right namePort), Nothing))
|
||||
|
||||
evalPattern :: Pat -> State IDState (GraphAndRef, Maybe String)
|
||||
evalPattern p = case p of
|
||||
PVar n -> pure (mempty, Left $ nameToString n)
|
||||
PLit s l -> fmap Right <$> evalPLit s l
|
||||
PVar n -> pure ((mempty, Left $ nameToString n), Nothing)
|
||||
PLit s l -> makePatternResult $ evalPLit s l
|
||||
PInfixApp p1 qName p2 -> evalPattern (PApp qName [p1, p2])
|
||||
PApp name patterns -> fmap Right <$> evalPApp name patterns
|
||||
PApp name patterns -> makePatternResult $ evalPApp name patterns
|
||||
-- TODO special tuple handling.
|
||||
PTuple _ patterns ->
|
||||
fmap Right <$> evalPApp (Exts.UnQual . Ident . nTupleString . length $ patterns) patterns
|
||||
makePatternResult $ evalPApp (Exts.UnQual . Ident . nTupleString . length $ patterns) patterns
|
||||
PList patterns ->
|
||||
fmap Right <$> evalPApp (Exts.UnQual . Ident . nListString . length $ patterns) patterns
|
||||
makePatternResult $ evalPApp (Exts.UnQual . Ident . nListString . length $ patterns) patterns
|
||||
PParen pat -> evalPattern pat
|
||||
PAsPat n subPat -> evalPAsPat n subPat
|
||||
PWildCard -> fmap Right <$> makeBox "_"
|
||||
PWildCard -> makePatternResult $ makeBox "_"
|
||||
_ -> error $ "evalPattern: No pattern in case for " ++ show p
|
||||
-- TODO: Other cases
|
||||
|
||||
@ -135,15 +147,24 @@ decideIfNested :: ((SyntaxGraph, t1), t) ->
|
||||
decideIfNested ((SyntaxGraph [nameAndIcon] [] sinks bindings eMap, _), _) = (Nothing, Just nameAndIcon, sinks, bindings, eMap)
|
||||
decideIfNested valAndPort = (Just valAndPort, Nothing, [], [], [])
|
||||
|
||||
asNameBind :: (GraphAndRef, Maybe String) -> Maybe (String, Reference)
|
||||
asNameBind ((_, ref), mAsName) = case mAsName of
|
||||
Nothing -> Nothing
|
||||
Just asName -> Just (asName, ref)
|
||||
|
||||
-- TODO Consider removing the Int numArgs parameter.
|
||||
makePatternGraph :: NodeName -> String -> [(SyntaxGraph, Reference)] -> Int -> (SyntaxGraph, NameAndPort)
|
||||
makePatternGraph :: NodeName -> String -> [(GraphAndRef, Maybe String)] -> Int -> (SyntaxGraph, NameAndPort)
|
||||
makePatternGraph applyIconName funStr argVals _ = nestedApplyResult
|
||||
where
|
||||
argumentPorts = map (nameAndPort applyIconName . Port) [2,3..]
|
||||
(unnestedArgsAndPort, nestedArgs, nestedSinks, nestedBindings, nestedEMaps) = unzip5 $ fmap decideIfNested (zip argVals argumentPorts)
|
||||
argValsWithoutAsNames = fmap fst argVals
|
||||
(unnestedArgsAndPort, nestedArgs, nestedSinks, nestedBindings, nestedEMaps) =
|
||||
unzip5 $ fmap decideIfNested (zip argValsWithoutAsNames argumentPorts)
|
||||
|
||||
asNameBinds = catMaybes $ fmap asNameBind argVals
|
||||
|
||||
allSinks = mconcat nestedSinks
|
||||
allBinds = mconcat nestedBindings
|
||||
allBinds = mconcat nestedBindings <> asNameBinds
|
||||
|
||||
originalPortExpPairs = catMaybes unnestedArgsAndPort
|
||||
portExpressionPairs = originalPortExpPairs
|
||||
@ -364,12 +385,12 @@ evalLet :: EvalContext -> Binds -> Exp -> State IDState (SyntaxGraph, Reference)
|
||||
evalLet context binds e = evalGeneralLet (`evalExp` e) context binds
|
||||
|
||||
-- TODO: Refactor this with evalPatBind
|
||||
evalPatAndRhs :: EvalContext -> Pat -> Rhs -> Maybe Binds -> State IDState (Bool, SyntaxGraph, Reference, Reference)
|
||||
evalPatAndRhs :: EvalContext -> Pat -> Rhs -> Maybe Binds -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String)
|
||||
evalPatAndRhs c pat rhs maybeWhereBinds = do
|
||||
patternNames <- namesInPattern <$> evalPattern pat
|
||||
let rhsContext = patternNames <> c
|
||||
(rhsGraph, rhsRef) <- rhsWithBinds maybeWhereBinds rhs rhsContext
|
||||
(patGraph, patRef) <- evalPattern pat
|
||||
((patGraph, patRef), mPatAsName) <- evalPattern pat
|
||||
let
|
||||
grWithEdges = makeEdges (rhsGraph <> patGraph)
|
||||
lookedUpRhsRef = lookupReference (sgSources grWithEdges) rhsRef
|
||||
@ -377,10 +398,10 @@ evalPatAndRhs c pat rhs maybeWhereBinds = do
|
||||
-- in the pattern
|
||||
patRhsAreConnected = (rhsRef /= lookedUpRhsRef) ||
|
||||
length (sgEdges grWithEdges) > (length (sgEdges rhsGraph) + length (sgEdges patGraph))
|
||||
pure (patRhsAreConnected, deleteBindings grWithEdges, patRef, lookedUpRhsRef)
|
||||
pure (patRhsAreConnected, deleteBindings grWithEdges, patRef, lookedUpRhsRef, mPatAsName)
|
||||
|
||||
-- returns (combined graph, pattern reference, rhs reference)
|
||||
evalAlt :: EvalContext -> Exts.Alt -> State IDState (Bool, SyntaxGraph, Reference, Reference)
|
||||
evalAlt :: EvalContext -> Exts.Alt -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String)
|
||||
evalAlt c (Exts.Alt _ pat rhs maybeBinds) = evalPatAndRhs c pat rhs maybeBinds
|
||||
|
||||
evalCase :: EvalContext -> Exp -> [Alt] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
@ -389,7 +410,7 @@ evalCase c e alts = do
|
||||
(expGraph, expRef) <- evalExp c e
|
||||
caseIconName <- getUniqueName "case"
|
||||
let
|
||||
(patRhsConnected, altGraphs, patRefs, rhsRefs) = unzip4 evaledAlts
|
||||
(patRhsConnected, altGraphs, patRefs, rhsRefs, asNames) = unzip5 evaledAlts
|
||||
combindedAltGraph = mconcat altGraphs
|
||||
numAlts = length alts
|
||||
icons = [(caseIconName, CaseNode numAlts)]
|
||||
@ -411,7 +432,10 @@ evalCase c e alts = do
|
||||
filteredRhsEdges = fmap snd unConnectedRhss
|
||||
patternEdgesGraph = edgesForRefPortList True patEdges
|
||||
caseEdgeGraph = edgesForRefPortList False (expEdge : filteredRhsEdges)
|
||||
finalGraph = mconcat [patternEdgesGraph, caseResultGraphs, expGraph, caseEdgeGraph, caseGraph, combindedAltGraph]
|
||||
|
||||
bindGraph = makeAsBindGraph expRef asNames
|
||||
|
||||
finalGraph = deleteBindings $ makeEdges $ mconcat [bindGraph, patternEdgesGraph, caseResultGraphs, expGraph, caseEdgeGraph, caseGraph, combindedAltGraph]
|
||||
pure (finalGraph, nameAndPort caseIconName (Port 1))
|
||||
|
||||
evalTuple :: EvalContext -> [Exp] -> State IDState (SyntaxGraph, NameAndPort)
|
||||
@ -500,7 +524,7 @@ evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
|
||||
patternNames <- namesInPattern <$> evalPattern pat
|
||||
let rhsContext = patternNames <> c
|
||||
(rhsGraph, rhsRef) <- rhsWithBinds maybeWhereBinds rhs rhsContext
|
||||
(patGraph, patRef) <- evalPattern pat
|
||||
((patGraph, patRef), patAsName) <- evalPattern pat
|
||||
let
|
||||
(newEdges, newSinks, bindings) = case patRef of
|
||||
(Left s) -> (mempty, mempty, [(s, rhsRef)])
|
||||
@ -508,15 +532,21 @@ evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
|
||||
-- TODO This edge/sink should have a special arrow head to indicate an input to a pattern.
|
||||
(Left rhsStr) -> (mempty, [(rhsStr, patPort)], mempty)
|
||||
(Right rhsPort) -> ([makeSimpleEdge (rhsPort, patPort)], mempty, mempty)
|
||||
gr = SyntaxGraph mempty newEdges newSinks bindings mempty
|
||||
asBindGraph = makeAsBindGraph rhsRef [patAsName]
|
||||
gr = asBindGraph <> SyntaxGraph mempty newEdges newSinks bindings mempty
|
||||
pure . makeEdges $ (gr <> rhsGraph <> patGraph)
|
||||
|
||||
-- TODO Returning a SyntaxGraph is probably not very efficient
|
||||
asBindGraphZipper :: Maybe String -> NameAndPort -> SyntaxGraph
|
||||
asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName]
|
||||
|
||||
generalEvalLambda :: EvalContext -> [Pat] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (SyntaxGraph, NameAndPort)
|
||||
generalEvalLambda context patterns rhsEvalFun = do
|
||||
lambdaName <- getUniqueName "lam"
|
||||
patternVals <- mapM evalPattern patterns
|
||||
patternValsWithAsNames <- mapM evalPattern patterns
|
||||
let
|
||||
patternStrings = concatMap namesInPattern patternVals
|
||||
patternVals = fmap fst patternValsWithAsNames
|
||||
patternStrings = concatMap namesInPattern patternValsWithAsNames
|
||||
rhsContext = patternStrings <> context
|
||||
lambdaPorts = map (nameAndPort lambdaName . Port) [2,3..]
|
||||
patternGraph = mconcat $ map fst patternVals
|
||||
@ -532,7 +562,10 @@ generalEvalLambda context patterns rhsEvalFun = do
|
||||
Left s -> (patternEdges, [(s, returnPort)])
|
||||
Right rhsPort -> (makeSimpleEdge (rhsPort, returnPort) : patternEdges, mempty)
|
||||
finalGraph = SyntaxGraph icons newEdges newSinks newBinds mempty
|
||||
pure (deleteBindings . makeEdges $ (rhsRawGraph <> patternGraph <> finalGraph), nameAndPort lambdaName (Port 1))
|
||||
|
||||
asBindGraph = mconcat $ zipWith asBindGraphZipper (fmap snd patternValsWithAsNames) lambdaPorts
|
||||
|
||||
pure (deleteBindings . makeEdges $ (asBindGraph <> rhsRawGraph <> patternGraph <> finalGraph), nameAndPort lambdaName (Port 1))
|
||||
where
|
||||
-- TODO Like evalPatBind, this edge should have an indicator that it is the input to a pattern.
|
||||
-- makePatternEdges creates the edges between the patterns and the parameter ports.
|
||||
@ -553,7 +586,7 @@ evalMatch c (Match _ name patterns _ rhs maybeWhereBinds) = do
|
||||
(lambdaGraph, lambdaPort) <-
|
||||
generalEvalLambda newContext patterns (rhsWithBinds maybeWhereBinds rhs)
|
||||
let
|
||||
newBinding = SyntaxGraph mempty mempty mempty [(matchFunNameString, Right lambdaPort)] mempty
|
||||
newBinding = bindsToSyntaxGraph [(matchFunNameString, Right lambdaPort)]
|
||||
pure $ makeEdges (newBinding <> lambdaGraph)
|
||||
|
||||
-- Only used by matchesToCase
|
||||
|
@ -117,9 +117,16 @@ makeApplyGraph applyFlavor inPattern applyIconName funVal argVals numArgs = (new
|
||||
icons = [(applyIconName, LikeApplyNode applyFlavor numArgs)]
|
||||
newGraph = syntaxGraphFromNodes icons
|
||||
|
||||
namesInPattern :: GraphAndRef -> [String]
|
||||
namesInPattern (_, Left str) = [str]
|
||||
namesInPattern (SyntaxGraph _ _ _ bindings _, Right _) = fmap fst bindings
|
||||
namesInPatternHelper :: GraphAndRef -> [String]
|
||||
namesInPatternHelper (_, Left str) = [str]
|
||||
namesInPatternHelper (SyntaxGraph _ _ _ bindings _, Right _) = fmap fst bindings
|
||||
|
||||
namesInPattern :: (GraphAndRef, Maybe String) -> [String]
|
||||
namesInPattern (graphAndRef, mName) = case mName of
|
||||
Nothing -> otherNames
|
||||
Just n -> n : otherNames
|
||||
where
|
||||
otherNames = namesInPatternHelper graphAndRef
|
||||
|
||||
-- | Recursivly find the matching reference in a list of bindings.
|
||||
-- TODO: Might want to present some indication if there is a reference cycle.
|
||||
|
@ -146,9 +146,12 @@ patternTests = [
|
||||
"Foo (Bar x) (Baz y) = f 1 2 x y",
|
||||
"Foo x y = f 1 y x",
|
||||
|
||||
-- TODO Fix so that "t" connects to the apply result, not the pattern.
|
||||
"t@(x,y) = (x,y)",
|
||||
"y = let {t@(_,_) = (3,4)} in t + 3",
|
||||
"n1@(n2@(x,y)) = f n1 n2 x y",
|
||||
"n0@(Foo n1@(Bar x) n2@(Baz y)) = f n0 n1 x n2 y",
|
||||
"baz = case 0 of {n0@(Foo n1@(Bar x) n2@(Baz y)) -> f n0 n1 x n2 y}",
|
||||
"func n0@(Foo n1@(Bar x) n2@(Baz y)) = f n0 n1 x n2 y",
|
||||
|
||||
"y = let {(x, y) = (1,2)} in x + y",
|
||||
"y = let {(x, y) = (1,2); (z, w) = x; (m, g) = y} in foo x y z w m g",
|
||||
|
7
todo.md
7
todo.md
@ -25,15 +25,8 @@
|
||||
* Use diagrams to shrink the drawing until icons start overlapping.
|
||||
|
||||
### Translate todos
|
||||
* Allow case and guard nodes to embed simple patterns and expressions.
|
||||
|
||||
* Fix this test so that the line colors are correct. Consider connecting the t line to the origial rhs (3,4), not the pattern result.
|
||||
y = let {t@(_,_) = (3,4)} in t + 3
|
||||
|
||||
* Fix applyComposeScore in Translate.hs not counting expressions that nest via reference. May need to move compose generation to after translate.
|
||||
|
||||
* Fix test case x of {0 -> 1; y -> y}.
|
||||
|
||||
* Add proper RecConstr, and RecUpdate support.
|
||||
|
||||
* Special case for otherwise.
|
||||
|
Loading…
Reference in New Issue
Block a user