mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Rewrite Translate.hs to use SimplifySyntax (#4)
* Create branch for in-progress SimplifySyntax work. * Translate more simple syntax. Improve flat lambda icon. Remove function binds from simple syntax. * Translate SeApp. * Fix simplifyExp. * Translate SpApp and SeCase. * Translate SeGuard. * Translate @ patterns and pattern wild cards. * Transtlate list and tuple patterns. * Translate tuple and list expressions. * Translate left sections. * Translate Do notation. * Cleanup Translate.hs. * Translate type signatures. * More cleanup of Translate.hs. * Translate negate function application and enum syntax. * Rename functions in Translate.hs.
This commit is contained in:
parent
d39e00e7a1
commit
3523e44399
@ -661,7 +661,7 @@ flatLambda paramNames (TransformParams name _ reflect angle)
|
|||||||
portIcons
|
portIcons
|
||||||
= zipWith (makeLabelledPort name reflect angle) paramNames argPortsConst
|
= zipWith (makeLabelledPort name reflect angle) paramNames argPortsConst
|
||||||
middle = alignL (hsep 0.5 lambdaParts)
|
middle = alignL (hsep 0.5 lambdaParts)
|
||||||
topAndBottomLineWidth = width middle - circleRadius
|
topAndBottomLineWidth = width middle - (circleRadius + defaultLineWidth)
|
||||||
topAndBottomLine
|
topAndBottomLine
|
||||||
= alignL
|
= alignL
|
||||||
$ lwG defaultLineWidth
|
$ lwG defaultLineWidth
|
||||||
|
@ -1,14 +1,30 @@
|
|||||||
module SimplifySyntax (
|
module SimplifySyntax (
|
||||||
stringToSimpDecl
|
SimpExp(..)
|
||||||
|
, SelectorAndVal(..)
|
||||||
|
, SimpAlt(..)
|
||||||
|
, SimpDecl(..)
|
||||||
|
, SimpPat(..)
|
||||||
|
, stringToSimpDecl
|
||||||
, qOpToExp
|
, qOpToExp
|
||||||
, qNameToString
|
, qNameToString
|
||||||
, nameToString
|
, nameToString
|
||||||
, customParseDecl
|
, customParseDecl
|
||||||
|
, hsDeclToSimpDecl
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Data.List(foldl')
|
||||||
|
import Data.Maybe(catMaybes, isJust)
|
||||||
|
|
||||||
import qualified Language.Haskell.Exts as Exts
|
import qualified Language.Haskell.Exts as Exts
|
||||||
|
|
||||||
import TranslateCore(nTupleString)
|
import TranslateCore(nTupleSectionString, nTupleString, nListString)
|
||||||
|
|
||||||
|
-- TODO use a data constructor for the special case instead of using string
|
||||||
|
-- matching for tempvars.
|
||||||
|
-- There is a special case in Icons.hs/makeLabelledPort to exclude " tempvar"
|
||||||
|
tempVarPrefix :: String
|
||||||
|
tempVarPrefix = " tempvar"
|
||||||
|
|
||||||
-- A simplified Haskell syntax tree
|
-- A simplified Haskell syntax tree
|
||||||
|
|
||||||
-- rhs is now SimpExp
|
-- rhs is now SimpExp
|
||||||
@ -40,8 +56,8 @@ data SimpAlt l = SimpAlt {
|
|||||||
|
|
||||||
data SimpDecl l =
|
data SimpDecl l =
|
||||||
-- These don't have decl lists, since only lets have decl lists
|
-- These don't have decl lists, since only lets have decl lists
|
||||||
SdFunBind l (Exts.Name l) [SimpPat l] (SimpExp l)
|
SdPatBind l (SimpPat l) (SimpExp l)
|
||||||
| SdPatBind l (SimpPat l) (SimpExp l)
|
| SdTypeSig l [Exts.Name l] (Exts.Type l)
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data SimpPat l =
|
data SimpPat l =
|
||||||
@ -49,12 +65,22 @@ data SimpPat l =
|
|||||||
| SpLit l (Exts.Sign l) (Exts.Literal l)
|
| SpLit l (Exts.Sign l) (Exts.Literal l)
|
||||||
| SpApp l (Exts.QName l) [SimpPat l]
|
| SpApp l (Exts.QName l) [SimpPat l]
|
||||||
| SpAsPat l (Exts.Name l) (SimpPat l)
|
| SpAsPat l (Exts.Name l) (SimpPat l)
|
||||||
|
| SpWildCard l
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
-- Helper functions
|
-- Helper functions
|
||||||
|
|
||||||
|
strToQName :: l -> String -> Exts.QName l
|
||||||
|
strToQName l = Exts.UnQual l . Exts.Ident l
|
||||||
|
|
||||||
makeVarExp :: l -> String -> Exts.Exp l
|
makeVarExp :: l -> String -> Exts.Exp l
|
||||||
makeVarExp l = Exts.Var l . Exts.UnQual l . Exts.Ident l
|
makeVarExp l = Exts.Var l . strToQName l
|
||||||
|
|
||||||
|
makePatVar :: l -> String -> Exts.Pat l
|
||||||
|
makePatVar l = Exts.PVar l . Exts.Ident l
|
||||||
|
|
||||||
|
makeQVarOp :: l -> String -> Exts.QOp l
|
||||||
|
makeQVarOp l = Exts.QVarOp l . Exts.UnQual l . Exts.Ident l
|
||||||
|
|
||||||
qOpToExp :: Exts.QOp l -> Exts.Exp l
|
qOpToExp :: Exts.QOp l -> Exts.Exp l
|
||||||
qOpToExp (Exts.QVarOp l n) = Exts.Var l n
|
qOpToExp (Exts.QVarOp l n) = Exts.Var l n
|
||||||
@ -80,28 +106,23 @@ qNameToString q = error $ "Unsupported syntax in qNameToSrting: " <> show q
|
|||||||
|
|
||||||
--
|
--
|
||||||
|
|
||||||
infixAppToSeApp :: Show a =>
|
|
||||||
a -> Exts.Exp a -> Exts.QOp a -> Exts.Exp a -> SimpExp a
|
|
||||||
infixAppToSeApp l e1 op e2 = case op of
|
|
||||||
Exts.QVarOp _ (Exts.UnQual _ (Exts.Symbol _ sym)) -> case sym of
|
|
||||||
"$" -> hsExpToSimpExp (Exts.App l e1 e2)
|
|
||||||
-- TODO
|
|
||||||
-- "." -> grNamePortToGrRef
|
|
||||||
-- <$> evalFunctionComposition c (e1 : compositionToList e2)
|
|
||||||
_ -> defaultCase
|
|
||||||
_ -> defaultCase
|
|
||||||
where
|
|
||||||
defaultCase = hsExpToSimpExp $ Exts.App l (Exts.App l (qOpToExp op) e1) e2
|
|
||||||
|
|
||||||
hsPatToSimpPat :: Show a => Exts.Pat a -> SimpPat a
|
hsPatToSimpPat :: Show a => Exts.Pat a -> SimpPat a
|
||||||
hsPatToSimpPat p = case p of
|
hsPatToSimpPat p = case p of
|
||||||
Exts.PVar l n -> SpVar l n
|
Exts.PVar l n -> SpVar l n
|
||||||
Exts.PLit l sign lit -> SpLit l sign lit
|
Exts.PLit l sign lit -> SpLit l sign lit
|
||||||
Exts.PInfixApp l p1 qName p2 -> hsPatToSimpPat (Exts.PApp l qName [p1, p2])
|
Exts.PInfixApp l p1 qName p2 -> hsPatToSimpPat (Exts.PApp l qName [p1, p2])
|
||||||
Exts.PApp l name patts -> SpApp l name (fmap hsPatToSimpPat patts)
|
Exts.PApp l name patts -> SpApp l name (fmap hsPatToSimpPat patts)
|
||||||
|
Exts.PTuple l _ patts -> SpApp
|
||||||
|
l
|
||||||
|
((strToQName l . nTupleString . length) patts)
|
||||||
|
(fmap hsPatToSimpPat patts)
|
||||||
Exts.PParen _ pat -> hsPatToSimpPat pat
|
Exts.PParen _ pat -> hsPatToSimpPat pat
|
||||||
Exts.PAsPat l name pat -> SpAsPat l name (hsPatToSimpPat pat)
|
Exts.PAsPat l name pat -> SpAsPat l name (hsPatToSimpPat pat)
|
||||||
-- TODO PTuple, PList, PWildCard
|
Exts.PWildCard l -> SpWildCard l
|
||||||
|
Exts.PList l patts -> SpApp
|
||||||
|
l
|
||||||
|
((strToQName l . nListString . length) patts)
|
||||||
|
(fmap hsPatToSimpPat patts)
|
||||||
_ -> error $ "Unsupported syntax in hsPatToSimpPat: " <> show p
|
_ -> error $ "Unsupported syntax in hsPatToSimpPat: " <> show p
|
||||||
|
|
||||||
whereToLet :: Show a => a -> Exts.Rhs a -> Maybe (Exts.Binds a) -> SimpExp a
|
whereToLet :: Show a => a -> Exts.Rhs a -> Maybe (Exts.Binds a) -> SimpExp a
|
||||||
@ -112,21 +133,24 @@ whereToLet l rhs maybeBinds = val
|
|||||||
Nothing -> rhsExp
|
Nothing -> rhsExp
|
||||||
Just binds -> SeLet l (hsBindsToDecls binds) rhsExp
|
Just binds -> SeLet l (hsBindsToDecls binds) rhsExp
|
||||||
|
|
||||||
matchToFunBind :: Show a => Exts.Match a -> SimpDecl a
|
matchToSimpDecl :: Show a => Exts.Match a -> SimpDecl a
|
||||||
matchToFunBind (Exts.Match l name patterns rhs maybeWhereBinds)
|
matchToSimpDecl (Exts.Match l name patterns rhs maybeWhereBinds)
|
||||||
= SdFunBind
|
= SdPatBind
|
||||||
l
|
l
|
||||||
name
|
(SpVar l name)
|
||||||
(fmap hsPatToSimpPat patterns)
|
(SeLambda l
|
||||||
(whereToLet l rhs maybeWhereBinds)
|
(fmap hsPatToSimpPat patterns)
|
||||||
matchToFunBind m = error $ "Unsupported syntax in matchToFunBind: " <> show m
|
(whereToLet l rhs maybeWhereBinds))
|
||||||
|
matchToSimpDecl m = error $ "Unsupported syntax in matchToSimpDecl: " <> show m
|
||||||
|
|
||||||
-- Only used by matchesToCase
|
-- Only used by matchesToCase
|
||||||
matchToAlt :: Show l => Exts.Match l -> Exts.Alt l
|
matchToAlt :: Show l => Exts.Match l -> Exts.Alt l
|
||||||
matchToAlt (Exts.Match l _ mtaPats rhs binds) = Exts.Alt l altPattern rhs binds where
|
matchToAlt (Exts.Match l _ mtaPats rhs binds)
|
||||||
altPattern = case mtaPats of
|
= Exts.Alt l altPattern rhs binds
|
||||||
[onePat] -> onePat
|
where
|
||||||
_ -> Exts.PTuple l Exts.Boxed mtaPats
|
altPattern = case mtaPats of
|
||||||
|
[onePat] -> onePat
|
||||||
|
_ -> Exts.PTuple l Exts.Boxed mtaPats
|
||||||
matchToAlt match = error $ "Unsupported syntax in matchToAlt: " <> show match
|
matchToAlt match = error $ "Unsupported syntax in matchToAlt: " <> show match
|
||||||
|
|
||||||
-- TODO Refactor matchesToCase
|
-- TODO Refactor matchesToCase
|
||||||
@ -135,10 +159,8 @@ matchesToCase match [] = match
|
|||||||
matchesToCase firstMatch@(Exts.Match srcLoc funName pats _ _) restOfMatches = match
|
matchesToCase firstMatch@(Exts.Match srcLoc funName pats _ _) restOfMatches = match
|
||||||
where
|
where
|
||||||
-- There is a special case in Icons.hs/makeLabelledPort to exclude " tempvar"
|
-- There is a special case in Icons.hs/makeLabelledPort to exclude " tempvar"
|
||||||
-- TODO use a data constructor for the special case instead of using string
|
tempStrings = fmap (\x -> tempVarPrefix ++ show x) [0..(length pats - 1)]
|
||||||
-- matching for tempvars.
|
tempPats = fmap (makePatVar srcLoc) tempStrings
|
||||||
tempStrings = fmap (\x -> " tempvar" ++ show x) [0..(length pats - 1)]
|
|
||||||
tempPats = fmap (Exts.PVar srcLoc . Exts.Ident srcLoc) tempStrings
|
|
||||||
tempVars = fmap (makeVarExp srcLoc) tempStrings
|
tempVars = fmap (makeVarExp srcLoc) tempStrings
|
||||||
tuple = Exts.Tuple srcLoc Exts.Boxed tempVars
|
tuple = Exts.Tuple srcLoc Exts.Boxed tempVars
|
||||||
caseExp = case tempVars of
|
caseExp = case tempVars of
|
||||||
@ -154,10 +176,11 @@ matchesToCase firstMatch _
|
|||||||
matchesToFunBind :: Show a => a -> [Exts.Match a] -> SimpDecl a
|
matchesToFunBind :: Show a => a -> [Exts.Match a] -> SimpDecl a
|
||||||
matchesToFunBind l matches = case matches of
|
matchesToFunBind l matches = case matches of
|
||||||
[] -> error $ "Empty matches in matchesToFunBind. Label is :" <> show l
|
[] -> error $ "Empty matches in matchesToFunBind. Label is :" <> show l
|
||||||
(m : ms) -> matchToFunBind (matchesToCase m ms)
|
(m : ms) -> matchToSimpDecl (matchesToCase m ms)
|
||||||
|
|
||||||
hsDeclToSimpDecl :: Show a => Exts.Decl a -> SimpDecl a
|
hsDeclToSimpDecl :: Show a => Exts.Decl a -> SimpDecl a
|
||||||
hsDeclToSimpDecl decl = case decl of
|
hsDeclToSimpDecl decl = case decl of
|
||||||
|
Exts.TypeSig l names typeForNames -> SdTypeSig l names typeForNames
|
||||||
Exts.FunBind l matches -> matchesToFunBind l matches
|
Exts.FunBind l matches -> matchesToFunBind l matches
|
||||||
Exts.PatBind l pat rhs maybeBinds -> SdPatBind l (hsPatToSimpPat pat) expr
|
Exts.PatBind l pat rhs maybeBinds -> SdPatBind l (hsPatToSimpPat pat) expr
|
||||||
where
|
where
|
||||||
@ -198,13 +221,65 @@ ifToGuard l e1 e2 e3
|
|||||||
where
|
where
|
||||||
otherwiseExp = SeName l "otherwise"
|
otherwiseExp = SeName l "otherwise"
|
||||||
|
|
||||||
|
simplifyExp :: SimpExp l -> SimpExp l
|
||||||
|
simplifyExp e = case e of
|
||||||
|
-- Reduce applications of function compositions (e.g. (f . g) x -> f (g x))
|
||||||
|
SeApp l2 (SeApp l1 (SeApp _ (SeName _ ".") f1) f2) arg
|
||||||
|
-> SeApp l1 f1 $ simplifyExp (SeApp l2 f2 arg)
|
||||||
|
SeApp l (SeApp _ (SeName _ "$") exp1) exp2
|
||||||
|
-> SeApp l exp1 exp2
|
||||||
|
SeApp l1 (SeName l2 "<$>") arg
|
||||||
|
-> SeApp l1 (SeName l2 "fmap") arg
|
||||||
|
x -> x
|
||||||
|
|
||||||
|
deListifyApp :: Show l => l -> Exts.Exp l -> [Exts.Exp l] -> Exts.Exp l
|
||||||
|
deListifyApp l = foldl' (Exts.App l)
|
||||||
|
|
||||||
|
rewriteTupleSection :: Show l => l -> [Maybe (Exts.Exp l)] -> Exts.Exp l
|
||||||
|
rewriteTupleSection l mExprs = deListifyApp
|
||||||
|
l
|
||||||
|
(makeVarExp l $ nTupleSectionString expIsJustList)
|
||||||
|
exprs
|
||||||
|
where
|
||||||
|
exprs = catMaybes mExprs
|
||||||
|
expIsJustList = fmap isJust mExprs
|
||||||
|
|
||||||
|
-- Rewrite a right section as a lambda.
|
||||||
|
-- TODO Simplify this type of lambda to use unused ports.
|
||||||
|
rewriteRightSection :: Show l => l -> Exts.QOp l -> Exts.Exp l -> Exts.Exp l
|
||||||
|
rewriteRightSection l op expr = Exts.Lambda l [tempPat] appExpr
|
||||||
|
where
|
||||||
|
tempStr = tempVarPrefix <> "0"
|
||||||
|
tempPat = makePatVar l tempStr
|
||||||
|
tempVar = makeVarExp l tempStr
|
||||||
|
appExpr = Exts.App l (Exts.App l (qOpToExp op) tempVar) expr
|
||||||
|
|
||||||
|
-- TODO refactor desugarDo
|
||||||
|
desugarDo :: Show l => [Exts.Stmt l] -> Exts.Exp l
|
||||||
|
desugarDo [Exts.Qualifier _ e] = e
|
||||||
|
desugarDo (Exts.Qualifier l e : stmts)
|
||||||
|
= Exts.InfixApp l e thenOp (desugarDo stmts)
|
||||||
|
where
|
||||||
|
thenOp = makeQVarOp l ">>"
|
||||||
|
desugarDo (Exts.Generator l pat e : stmts) =
|
||||||
|
Exts.InfixApp l e (makeQVarOp l ">>=") (Exts.Lambda l [pat] (desugarDo stmts))
|
||||||
|
desugarDo (Exts.LetStmt l binds : stmts) = Exts.Let l binds (desugarDo stmts)
|
||||||
|
desugarDo stmts = error $ "Unsupported syntax in degugarDo: " <> show stmts
|
||||||
|
|
||||||
|
desugarEnums :: Show l => l -> String -> [Exts.Exp l] -> SimpExp l
|
||||||
|
desugarEnums l funcName exprs = hsExpToSimpExp $ deListifyApp l
|
||||||
|
(makeVarExp l funcName)
|
||||||
|
exprs
|
||||||
|
|
||||||
hsExpToSimpExp :: Show a => Exts.Exp a -> SimpExp a
|
hsExpToSimpExp :: Show a => Exts.Exp a -> SimpExp a
|
||||||
hsExpToSimpExp x = case x of
|
hsExpToSimpExp x = simplifyExp $ case x of
|
||||||
Exts.Var l n -> SeName l (qNameToString n)
|
Exts.Var l n -> SeName l (qNameToString n)
|
||||||
Exts.Con l n -> SeName l (qNameToString n)
|
Exts.Con l n -> SeName l (qNameToString n)
|
||||||
Exts.Lit l n -> SeLit l n
|
Exts.Lit l n -> SeLit l n
|
||||||
Exts.InfixApp l e1 op e2 -> infixAppToSeApp l e1 op e2
|
Exts.InfixApp l e1 op e2 ->
|
||||||
|
hsExpToSimpExp $ Exts.App l (Exts.App l (qOpToExp op) e1) e2
|
||||||
Exts.App l f arg -> SeApp l (hsExpToSimpExp f) (hsExpToSimpExp arg)
|
Exts.App l f arg -> SeApp l (hsExpToSimpExp f) (hsExpToSimpExp arg)
|
||||||
|
Exts.NegApp l e -> hsExpToSimpExp $ Exts.App l (makeVarExp l "negate") e
|
||||||
Exts.Lambda l patterns e
|
Exts.Lambda l patterns e
|
||||||
-> SeLambda l (fmap hsPatToSimpPat patterns) (hsExpToSimpExp e)
|
-> SeLambda l (fmap hsPatToSimpPat patterns) (hsExpToSimpExp e)
|
||||||
Exts.Let l bs e -> SeLet l (hsBindsToDecls bs) (hsExpToSimpExp e)
|
Exts.Let l bs e -> SeLet l (hsBindsToDecls bs) (hsExpToSimpExp e)
|
||||||
@ -212,6 +287,22 @@ hsExpToSimpExp x = case x of
|
|||||||
-> ifToGuard l (hsExpToSimpExp e1) (hsExpToSimpExp e2) (hsExpToSimpExp e3)
|
-> ifToGuard l (hsExpToSimpExp e1) (hsExpToSimpExp e2) (hsExpToSimpExp e3)
|
||||||
Exts.Case l e alts -> SeCase l (hsExpToSimpExp e) (fmap hsAltToSimpAlt alts)
|
Exts.Case l e alts -> SeCase l (hsExpToSimpExp e) (fmap hsAltToSimpAlt alts)
|
||||||
Exts.Paren _ e -> hsExpToSimpExp e
|
Exts.Paren _ e -> hsExpToSimpExp e
|
||||||
|
Exts.List l exprs -> hsExpToSimpExp $ deListifyApp
|
||||||
|
l
|
||||||
|
(makeVarExp l $ nListString $ length exprs)
|
||||||
|
exprs
|
||||||
|
Exts.Tuple l _ exprs -> hsExpToSimpExp $ deListifyApp
|
||||||
|
l
|
||||||
|
(makeVarExp l $ nTupleString $ length exprs)
|
||||||
|
exprs
|
||||||
|
Exts.TupleSection l _ mExprs -> hsExpToSimpExp $ rewriteTupleSection l mExprs
|
||||||
|
Exts.LeftSection l expr op -> hsExpToSimpExp $ Exts.App l (qOpToExp op) expr
|
||||||
|
Exts.RightSection l op expr -> hsExpToSimpExp $ rewriteRightSection l op expr
|
||||||
|
Exts.Do _ stmts -> hsExpToSimpExp $ desugarDo stmts
|
||||||
|
Exts.EnumFrom l e -> desugarEnums l "enumFrom" [e]
|
||||||
|
Exts.EnumFromTo l e1 e2 -> desugarEnums l "enumFromTo" [e1, e2]
|
||||||
|
Exts.EnumFromThen l e1 e2 -> desugarEnums l "enumFromThen" [e1, e2]
|
||||||
|
Exts.EnumFromThenTo l e1 e2 e3 -> desugarEnums l "enumFromThenTo" [e1, e2, e3]
|
||||||
_ -> error $ "Unsupported syntax in hsExpToSimpExp: " ++ show x
|
_ -> error $ "Unsupported syntax in hsExpToSimpExp: " ++ show x
|
||||||
|
|
||||||
-- Parsing
|
-- Parsing
|
||||||
|
540
app/Translate.hs
540
app/Translate.hs
@ -5,7 +5,6 @@ module Translate(
|
|||||||
translateModuleToCollapsedGraphs,
|
translateModuleToCollapsedGraphs,
|
||||||
qOpToExp,
|
qOpToExp,
|
||||||
qNameToString,
|
qNameToString,
|
||||||
matchesToCase,
|
|
||||||
customParseDecl
|
customParseDecl
|
||||||
) where
|
) where
|
||||||
|
|
||||||
@ -16,28 +15,25 @@ import Control.Monad.State(State, evalState)
|
|||||||
import Data.Either(partitionEithers)
|
import Data.Either(partitionEithers)
|
||||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||||
import Data.List(unzip5, partition, intercalate)
|
import Data.List(unzip5, partition, intercalate)
|
||||||
import Data.Maybe(catMaybes, isJust, fromMaybe)
|
import Data.Maybe(catMaybes, fromMaybe)
|
||||||
|
|
||||||
import qualified Language.Haskell.Exts as Exts
|
import qualified Language.Haskell.Exts as Exts
|
||||||
|
|
||||||
import Language.Haskell.Exts(
|
|
||||||
Decl(..), Name(..), Pat(..), Rhs(..),
|
|
||||||
Exp(..), QName(..), Match(..), QOp(..), GuardedRhs(..),
|
|
||||||
Stmt(..), Binds(..), Alt(..), Module(..), prettyPrint)
|
|
||||||
|
|
||||||
import GraphAlgorithms(collapseNodes)
|
import GraphAlgorithms(collapseNodes)
|
||||||
import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts,
|
import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts,
|
||||||
casePatternPorts)
|
casePatternPorts)
|
||||||
import SimplifySyntax(qOpToExp, qNameToString, nameToString, customParseDecl)
|
import SimplifySyntax(SimpAlt(..), stringToSimpDecl, SimpExp(..), SimpPat(..)
|
||||||
import TranslateCore(
|
, qOpToExp
|
||||||
Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..), SgSink(..),
|
, qNameToString, nameToString, customParseDecl
|
||||||
syntaxGraphFromNodes, syntaxGraphFromNodesEdges, getUniqueName,
|
, SimpDecl(..), hsDeclToSimpDecl, SelectorAndVal(..))
|
||||||
edgesForRefPortList, makeApplyGraph, makeGuardGraph, combineExpressions,
|
import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..)
|
||||||
namesInPattern, lookupReference, deleteBindings, makeEdges,
|
, SgSink(..), syntaxGraphFromNodes
|
||||||
makeBox, nTupleString, nTupleSectionString, nListString,
|
, syntaxGraphFromNodesEdges, getUniqueName
|
||||||
syntaxGraphToFglGraph, getUniqueString, bindsToSyntaxGraph,
|
, edgesForRefPortList, makeApplyGraph, makeGuardGraph
|
||||||
SgBind(..), graphAndRefToGraph,
|
, combineExpressions, namesInPattern, lookupReference
|
||||||
initialIdState)
|
, deleteBindings, makeEdges, makeBox, syntaxGraphToFglGraph
|
||||||
|
, getUniqueString, bindsToSyntaxGraph, SgBind(..)
|
||||||
|
, graphAndRefToGraph, initialIdState)
|
||||||
import Types(Labeled(..), NameAndPort(..), IDState,
|
import Types(Labeled(..), NameAndPort(..), IDState,
|
||||||
Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, SgNamedNode(..),
|
Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, SgNamedNode(..),
|
||||||
LikeApplyFlavor(..))
|
LikeApplyFlavor(..))
|
||||||
@ -52,12 +48,6 @@ import Util(makeSimpleEdge, nameAndPort, justName)
|
|||||||
|
|
||||||
-- BEGIN Helper Functions --
|
-- BEGIN Helper Functions --
|
||||||
|
|
||||||
makeVarExp :: l -> String -> Exp l
|
|
||||||
makeVarExp l = Var l . UnQual l . Ident l
|
|
||||||
|
|
||||||
makeQVarOp :: l -> String -> QOp l
|
|
||||||
makeQVarOp l = QVarOp l . UnQual l . Ident l
|
|
||||||
|
|
||||||
-- | Make a syntax graph that has the bindings for a list of "as pattern" (@)
|
-- | Make a syntax graph that has the bindings for a list of "as pattern" (@)
|
||||||
-- names.
|
-- names.
|
||||||
makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph
|
makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph
|
||||||
@ -71,19 +61,20 @@ makeAsBindGraph ref asNames
|
|||||||
grNamePortToGrRef :: (SyntaxGraph, NameAndPort) -> GraphAndRef
|
grNamePortToGrRef :: (SyntaxGraph, NameAndPort) -> GraphAndRef
|
||||||
grNamePortToGrRef (graph, np) = GraphAndRef graph (Right np)
|
grNamePortToGrRef (graph, np) = GraphAndRef graph (Right np)
|
||||||
|
|
||||||
|
-- TODO Find a better name for bindOrAltHelper
|
||||||
bindOrAltHelper :: Show l =>
|
bindOrAltHelper :: Show l =>
|
||||||
EvalContext
|
EvalContext
|
||||||
-> Pat l
|
-> SimpPat l
|
||||||
-> Rhs l
|
-> SimpExp l
|
||||||
-> Maybe (Binds l)
|
|
||||||
-> State IDState ((GraphAndRef, Maybe String), GraphAndRef)
|
-> State IDState ((GraphAndRef, Maybe String), GraphAndRef)
|
||||||
bindOrAltHelper c pat rhs maybeWhereBinds = do
|
bindOrAltHelper c pat e = do
|
||||||
patGraphAndRef <- evalPattern pat
|
patGraphAndRef <- evalPattern pat
|
||||||
let
|
let
|
||||||
rhsContext = namesInPattern patGraphAndRef <> c
|
rhsContext = namesInPattern patGraphAndRef <> c
|
||||||
rhsGraphAndRef <- rhsWithBinds maybeWhereBinds rhs rhsContext
|
rhsGraphAndRef <- evalExp rhsContext e
|
||||||
pure (patGraphAndRef, rhsGraphAndRef)
|
pure (patGraphAndRef, rhsGraphAndRef)
|
||||||
|
|
||||||
|
|
||||||
patternName :: (GraphAndRef, Maybe String) -> String
|
patternName :: (GraphAndRef, Maybe String) -> String
|
||||||
patternName (GraphAndRef _ ref, mStr) = fromMaybe
|
patternName (GraphAndRef _ ref, mStr) = fromMaybe
|
||||||
(case ref of
|
(case ref of
|
||||||
@ -193,8 +184,8 @@ makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult
|
|||||||
|
|
||||||
|
|
||||||
evalPApp :: Show l =>
|
evalPApp :: Show l =>
|
||||||
QName l
|
Exts.QName l
|
||||||
-> [Pat l]
|
-> [SimpPat l]
|
||||||
-> State IDState (SyntaxGraph, NameAndPort)
|
-> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalPApp name patterns = case patterns of
|
evalPApp name patterns = case patterns of
|
||||||
[] -> makeBox constructorName
|
[] -> makeBox constructorName
|
||||||
@ -204,6 +195,7 @@ evalPApp name patterns = case patterns of
|
|||||||
pure $ makeNestedPatternGraph patName constructorName evaledPatterns
|
pure $ makeNestedPatternGraph patName constructorName evaledPatterns
|
||||||
where
|
where
|
||||||
constructorName = qNameToString name
|
constructorName = qNameToString name
|
||||||
|
|
||||||
-- END evalPApp
|
-- END evalPApp
|
||||||
|
|
||||||
-- BEGIN evalPLit
|
-- BEGIN evalPLit
|
||||||
@ -229,7 +221,7 @@ evalPLit sign l = case sign of
|
|||||||
-- END evalPLit
|
-- END evalPLit
|
||||||
|
|
||||||
evalPAsPat :: Show l =>
|
evalPAsPat :: Show l =>
|
||||||
Name l -> Pat l -> State IDState (GraphAndRef, Maybe String)
|
Exts.Name l -> SimpPat l -> State IDState (GraphAndRef, Maybe String)
|
||||||
evalPAsPat n p = do
|
evalPAsPat n p = do
|
||||||
(GraphAndRef evaledPatGraph evaledPatRef, mInnerName) <- evalPattern p
|
(GraphAndRef evaledPatGraph evaledPatRef, mInnerName) <- evalPattern p
|
||||||
let
|
let
|
||||||
@ -243,26 +235,14 @@ makePatternResult :: Functor f =>
|
|||||||
makePatternResult
|
makePatternResult
|
||||||
= fmap (\(graph, namePort) -> (GraphAndRef graph (Right namePort), Nothing))
|
= fmap (\(graph, namePort) -> (GraphAndRef graph (Right namePort), Nothing))
|
||||||
|
|
||||||
evalPattern :: Show l => Pat l -> State IDState (GraphAndRef, Maybe String)
|
evalPattern :: Show l => SimpPat l -> State IDState (GraphAndRef, Maybe String)
|
||||||
evalPattern p = case p of
|
evalPattern p = case p of
|
||||||
PVar _ n -> pure (GraphAndRef mempty (Left $ nameToString n), Nothing)
|
SpVar _ n -> pure (GraphAndRef mempty (Left $ nameToString n), Nothing)
|
||||||
PLit _ s l -> makePatternResult $ evalPLit s l
|
SpLit _ sign lit -> makePatternResult $ evalPLit sign lit
|
||||||
PInfixApp l p1 qName p2 -> evalPattern (PApp l qName [p1, p2])
|
SpApp _ name patterns -> makePatternResult $ evalPApp name patterns
|
||||||
PApp _ name patterns -> makePatternResult $ evalPApp name patterns
|
SpAsPat _ name pat -> evalPAsPat name pat
|
||||||
-- TODO special tuple handling.
|
SpWildCard _ -> makePatternResult $ makeBox "_"
|
||||||
PTuple l _ patterns ->
|
-- _ -> error ("evalPattern todo: " <> show p)
|
||||||
makePatternResult $ evalPApp
|
|
||||||
(Exts.UnQual l . Ident l . nTupleString . length $ patterns)
|
|
||||||
patterns
|
|
||||||
PList l patterns ->
|
|
||||||
makePatternResult $ evalPApp
|
|
||||||
(Exts.UnQual l . Ident l . nListString . length $ patterns)
|
|
||||||
patterns
|
|
||||||
PParen _ pat -> evalPattern pat
|
|
||||||
PAsPat _ n subPat -> evalPAsPat n subPat
|
|
||||||
PWildCard _ -> makePatternResult $ makeBox "_"
|
|
||||||
_ -> error $ "evalPattern: No pattern in case for " ++ show p
|
|
||||||
-- TODO: Other cases
|
|
||||||
|
|
||||||
-- END evalPattern
|
-- END evalPattern
|
||||||
|
|
||||||
@ -275,43 +255,14 @@ strToGraphRef c str = fmap mapper (makeBox str) where
|
|||||||
then GraphAndRef mempty (Left str)
|
then GraphAndRef mempty (Left str)
|
||||||
else grNamePortToGrRef gr
|
else grNamePortToGrRef gr
|
||||||
|
|
||||||
evalQName :: Show l => QName l -> EvalContext -> State IDState GraphAndRef
|
|
||||||
evalQName qName c = case qName of
|
|
||||||
UnQual _ _ -> graphRef
|
|
||||||
Qual _ _ _ -> graphRef
|
|
||||||
_ -> grNamePortToGrRef <$> makeBox qNameString
|
|
||||||
where
|
|
||||||
qNameString = qNameToString qName
|
|
||||||
graphRef = strToGraphRef c qNameString
|
|
||||||
|
|
||||||
-- END evalQName
|
-- END evalQName
|
||||||
|
|
||||||
-- TODO Delete these commented out functions.
|
|
||||||
-- evalQOp :: QOp l -> EvalContext -> State IDState GraphAndRef
|
|
||||||
-- evalQOp (QVarOp n) = evalQName n
|
|
||||||
-- evalQOp (QConOp n) = evalQName n
|
|
||||||
|
|
||||||
-- qOpToString :: QOp l -> String
|
|
||||||
-- qOpToString (QVarOp n) = qNameToString n
|
|
||||||
-- qOpToString (QConOp n) = qNameToString n
|
|
||||||
|
|
||||||
--findReferencedIcon :: Reference -> [(NodeName, Icon)] -> Maybe (Name, Icon)
|
|
||||||
-- findReferencedIcon :: Either t NameAndPort -> [(NodeName, t1)] -> Maybe (NodeName, t1)
|
|
||||||
-- findReferencedIcon (Left str) _ = Nothing
|
|
||||||
-- findReferencedIcon (Right (NameAndPort name _)) nameIconMap = (\x -> (name, x)) <$> lookup name nameIconMap
|
|
||||||
|
|
||||||
|
|
||||||
-- BEGIN apply and compose helper functions
|
-- BEGIN apply and compose helper functions
|
||||||
|
|
||||||
removeParen :: Exp l -> Exp l
|
|
||||||
removeParen e = case e of
|
|
||||||
Paren _ x -> removeParen x
|
|
||||||
_ -> e
|
|
||||||
|
|
||||||
evalFunExpAndArgs :: Show l =>
|
evalFunExpAndArgs :: Show l =>
|
||||||
EvalContext
|
EvalContext
|
||||||
-> LikeApplyFlavor
|
-> LikeApplyFlavor
|
||||||
-> (Exp l, [Exp l])
|
-> (SimpExp l, [SimpExp l])
|
||||||
-> State IDState (SyntaxGraph, NameAndPort)
|
-> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalFunExpAndArgs c flavor (funExp, argExps) = do
|
evalFunExpAndArgs c flavor (funExp, argExps) = do
|
||||||
funVal <- evalExp c funExp
|
funVal <- evalExp c funExp
|
||||||
@ -322,10 +273,8 @@ evalFunExpAndArgs c flavor (funExp, argExps) = do
|
|||||||
|
|
||||||
-- END apply and compose helper functions
|
-- END apply and compose helper functions
|
||||||
|
|
||||||
-- BEGIN evalInfixApp
|
|
||||||
|
|
||||||
evalFunctionComposition :: Show l =>
|
evalFunctionComposition :: Show l =>
|
||||||
EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort)
|
EvalContext -> [SimpExp l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalFunctionComposition c functions = do
|
evalFunctionComposition c functions = do
|
||||||
let reversedFunctios = reverse functions
|
let reversedFunctios = reverse functions
|
||||||
evaluatedFunctions <- mapM (evalExp c) reversedFunctios
|
evaluatedFunctions <- mapM (evalExp c) reversedFunctios
|
||||||
@ -340,47 +289,18 @@ evalFunctionComposition c functions = do
|
|||||||
evaluatedFunctions
|
evaluatedFunctions
|
||||||
|
|
||||||
-- | Turn (a . b . c) into [a, b, c]
|
-- | Turn (a . b . c) into [a, b, c]
|
||||||
compositionToList :: Exp l -> [Exp l]
|
compositionToList :: SimpExp l -> [SimpExp l]
|
||||||
compositionToList e = case removeParen e of
|
compositionToList e = case e of
|
||||||
(InfixApp _ exp1 (QVarOp _ (UnQual _ (Symbol _ "."))) exp2)
|
(SeApp _ (SeApp _ (SeName _ ".") f1) f2)
|
||||||
-> exp1 : compositionToList exp2
|
-> f1 : compositionToList f2
|
||||||
x -> [x]
|
x -> [x]
|
||||||
|
|
||||||
-- | In the general case, infix is converted to prefix.
|
|
||||||
-- Special cases:
|
|
||||||
-- a $ b is converted to (a b)
|
|
||||||
-- (a . b . c) uses the compose apply icon with no argument
|
|
||||||
evalInfixApp :: Show l =>
|
|
||||||
l -> EvalContext -> Exp l -> QOp l -> Exp l -> State IDState GraphAndRef
|
|
||||||
evalInfixApp l c e1 op e2 = case op of
|
|
||||||
QVarOp _ (UnQual _ (Symbol _ sym)) -> case sym of
|
|
||||||
"$" -> evalExp c (App l e1 e2)
|
|
||||||
"." -> grNamePortToGrRef
|
|
||||||
<$> evalFunctionComposition c (e1 : compositionToList e2)
|
|
||||||
_ -> defaultCase
|
|
||||||
_ -> defaultCase
|
|
||||||
where
|
|
||||||
defaultCase = evalExp c $ App l (App l (qOpToExp op) e1) e2
|
|
||||||
|
|
||||||
-- END evalInfixApp
|
|
||||||
|
|
||||||
-- BEGIN evaluateAppExpression
|
-- BEGIN evaluateAppExpression
|
||||||
|
|
||||||
simplifyExp :: Exp l -> Exp l
|
|
||||||
simplifyExp e = case removeParen e of
|
|
||||||
InfixApp l exp1 (QVarOp _ (UnQual _ (Symbol _ "$"))) exp2 -> App l exp1 exp2
|
|
||||||
-- Don't convert compose to apply
|
|
||||||
InfixApp _ _ (QVarOp _ (UnQual _ (Symbol _ "."))) _ -> e
|
|
||||||
App l (Var _ (UnQual _ (Symbol _ "<$>"))) arg
|
|
||||||
-> App l (makeVarExp l "fmap") arg
|
|
||||||
InfixApp l exp1 op exp2 -> App l (App l (qOpToExp op) exp1) exp2
|
|
||||||
LeftSection l exp1 op -> App l (qOpToExp op) exp1
|
|
||||||
x -> x
|
|
||||||
|
|
||||||
-- | Given two expressions f and x, where f is applied to x,
|
-- | Given two expressions f and x, where f is applied to x,
|
||||||
-- return the nesting depth if (f x) is rendered with
|
-- return the nesting depth if (f x) is rendered with
|
||||||
-- the (normal apply icon, compose apply icon)
|
-- the (normal apply icon, compose apply icon)
|
||||||
applyComposeScoreHelper :: Exp l -> Exp l -> (Int, Int)
|
applyComposeScoreHelper :: SimpExp l -> SimpExp l -> (Int, Int)
|
||||||
applyComposeScoreHelper exp1 exp2 = (appScore, compScore) where
|
applyComposeScoreHelper exp1 exp2 = (appScore, compScore) where
|
||||||
(e1App, e1Comp) = applyComposeScore exp1
|
(e1App, e1Comp) = applyComposeScore exp1
|
||||||
(e2App, e2Comp) = applyComposeScore exp2
|
(e2App, e2Comp) = applyComposeScore exp2
|
||||||
@ -395,96 +315,77 @@ applyComposeScoreHelper exp1 exp2 = (appScore, compScore) where
|
|||||||
|
|
||||||
compScore = max leftComp rightComp
|
compScore = max leftComp rightComp
|
||||||
|
|
||||||
|
|
||||||
-- TODO Consider putting this logic in a separate "simplifyExpression" function.
|
-- TODO Consider putting this logic in a separate "simplifyExpression" function.
|
||||||
-- | Returns the amount of nesting if the App is converted to
|
-- | Returns the amount of nesting if the App is converted to
|
||||||
-- (applyNode, composeNode)
|
-- (applyNode, composeNode)
|
||||||
applyComposeScore :: Exp l -> (Int, Int)
|
applyComposeScore :: SimpExp l -> (Int, Int)
|
||||||
applyComposeScore e = case simplifyExp e of
|
applyComposeScore e = case e of
|
||||||
App _ exp1 exp2 -> applyComposeScoreHelper exp1 exp2
|
SeApp _ exp1 exp2 -> applyComposeScoreHelper exp1 exp2
|
||||||
_ -> (0, 0)
|
_ -> (0, 0)
|
||||||
|
|
||||||
-- Todo add test for this function
|
-- Todo add test for this function
|
||||||
-- | Given an App expression, return
|
-- | Given an App expression, return
|
||||||
-- (function, list of arguments)
|
-- (function, list of arguments)
|
||||||
appExpToFuncArgs :: Exp l -> (Exp l, [Exp l])
|
appExpToFuncArgs :: SimpExp l -> (SimpExp l, [SimpExp l])
|
||||||
appExpToFuncArgs e = case simplifyExp e of
|
appExpToFuncArgs e = case e of
|
||||||
App _ exp1 exp2 -> (funExp, args <> [exp2])
|
SeApp _ exp1 exp2 -> (funExp, args <> [exp2])
|
||||||
where
|
where
|
||||||
(funExp, args) = appExpToFuncArgs exp1
|
(funExp, args) = appExpToFuncArgs exp1
|
||||||
x -> (x, [])
|
x -> (x, [])
|
||||||
|
|
||||||
-- | Given and App expression, return
|
-- | Given and App expression, return
|
||||||
-- (argument, list composed functions)
|
-- (argument, list composed functions)
|
||||||
appExpToArgFuncs :: Exp l -> (Exp l, [Exp l])
|
appExpToArgFuncs :: SimpExp l -> (SimpExp l, [SimpExp l])
|
||||||
appExpToArgFuncs e = case simplifyExp e of
|
appExpToArgFuncs e = case e of
|
||||||
App _ exp1 exp2 -> (argExp, funcs <> [exp1])
|
SeApp _ exp1 exp2 -> (argExp, funcs <> [exp1])
|
||||||
where
|
where
|
||||||
(argExp, funcs) = appExpToArgFuncs exp2
|
(argExp, funcs) = appExpToArgFuncs exp2
|
||||||
simpleExp -> (simpleExp, [])
|
simpleExp -> (simpleExp, [])
|
||||||
|
|
||||||
removeCompose :: l -> Exp l -> Exp l -> Exp l
|
|
||||||
removeCompose l f x = case removeParen f of
|
|
||||||
(InfixApp _ f1 (QVarOp _ (UnQual _ (Symbol _ "."))) f2)
|
|
||||||
-> App l f1 $ removeCompose l f2 x
|
|
||||||
_ -> App l f x
|
|
||||||
|
|
||||||
-- TODO Refactor this and all sub-expressions
|
-- TODO Refactor this and all sub-expressions
|
||||||
evalApp :: Show l =>
|
evalApp :: Show l =>
|
||||||
l -> EvalContext -> Exp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
|
EvalContext -> SimpExp l
|
||||||
evalApp l c f e = if appScore <= compScore
|
-> State IDState (SyntaxGraph, NameAndPort)
|
||||||
then evalFunExpAndArgs c ApplyNodeFlavor (appExpToFuncArgs noComposeExp)
|
evalApp c expr = case expr of
|
||||||
else evalFunExpAndArgs c ComposeNodeFlavor (appExpToArgFuncs noComposeExp)
|
-- TODO This pattern for "." appears at least twice in this file. Refactor?
|
||||||
where
|
(SeApp _ (SeApp _ (SeName _ ".") _) _)
|
||||||
noComposeExp = removeCompose l f e
|
-> evalFunctionComposition c (compositionToList expr)
|
||||||
(appScore, compScore) = applyComposeScore noComposeExp
|
_ -> if appScore <= compScore
|
||||||
|
then evalFunExpAndArgs c ApplyNodeFlavor (appExpToFuncArgs expr)
|
||||||
|
else evalFunExpAndArgs c ComposeNodeFlavor (appExpToArgFuncs expr)
|
||||||
|
where
|
||||||
|
(appScore, compScore) = applyComposeScore expr
|
||||||
|
|
||||||
-- END evaluateAppExpression
|
-- END evaluateAppExpression
|
||||||
|
|
||||||
evalIf :: Show l =>
|
|
||||||
EvalContext
|
|
||||||
-> Exp l
|
|
||||||
-> Exp l
|
|
||||||
-> Exp l
|
|
||||||
-> State IDState (SyntaxGraph, NameAndPort)
|
|
||||||
evalIf c boolExp trueExp falseExp = makeGuardGraph 2
|
|
||||||
<$>
|
|
||||||
getUniqueName
|
|
||||||
<*>
|
|
||||||
-- Use (pure <$>) to put the evaluated expression in a single item list
|
|
||||||
(pure <$> evalExp c boolExp)
|
|
||||||
<*>
|
|
||||||
mapM (evalExp c) [trueExp, falseExp]
|
|
||||||
|
|
||||||
-- BEGIN evalGeneralLet
|
-- BEGIN evalGeneralLet
|
||||||
|
|
||||||
getBoundVarName :: Show l => Decl l -> [String]
|
getBoundVarName :: Show l => SimpDecl l -> [String]
|
||||||
-- TODO Should evalState be used here?
|
getBoundVarName d = case d of
|
||||||
getBoundVarName (PatBind _ pat _ _)
|
SdPatBind _ pat _ -> namesInPattern
|
||||||
= namesInPattern $ evalState (evalPattern pat) initialIdState
|
-- TODO Should evalState be used here?
|
||||||
getBoundVarName (FunBind _ (Match _ name _ _ _:_)) = [nameToString name]
|
$ evalState (evalPattern pat) initialIdState
|
||||||
-- TODO: Other cases
|
SdTypeSig _ _ _ -> []
|
||||||
getBoundVarName (TypeSig _ _ _) = []
|
|
||||||
getBoundVarName decl
|
|
||||||
= error $ "getBoundVarName: No pattern in case for " ++ show decl
|
|
||||||
|
|
||||||
evalBinds :: Show l =>
|
evalDecls :: Show l =>
|
||||||
EvalContext -> Binds l -> State IDState (SyntaxGraph, EvalContext)
|
EvalContext -> [SimpDecl l] -> State IDState (SyntaxGraph, EvalContext)
|
||||||
evalBinds c (BDecls _ decls) =
|
evalDecls c decls =
|
||||||
let
|
let
|
||||||
boundNames = concatMap getBoundVarName decls
|
boundNames = concatMap getBoundVarName decls
|
||||||
augmentedContext = boundNames <> c
|
augmentedContext = boundNames <> c
|
||||||
in
|
in
|
||||||
(,augmentedContext) . mconcat <$> mapM (evalDecl augmentedContext) decls
|
(,augmentedContext) . mconcat <$> mapM (evalDecl augmentedContext) decls
|
||||||
evalBinds _ binds = error $ "Unsupported syntax in evalBinds: " <> show binds
|
|
||||||
|
|
||||||
evalGeneralLet :: Show l =>
|
evalLet :: Show l =>
|
||||||
(EvalContext -> State IDState GraphAndRef)
|
EvalContext
|
||||||
-> EvalContext
|
-> [SimpDecl l]
|
||||||
-> Binds l
|
-> SimpExp l
|
||||||
-> State IDState GraphAndRef
|
-> State IDState GraphAndRef
|
||||||
evalGeneralLet expOrRhsEvaler c bs = do
|
evalLet c decls expr = do
|
||||||
(bindGraph, bindContext) <- evalBinds c bs
|
(bindGraph, bindContext) <- evalDecls c decls
|
||||||
expVal <- expOrRhsEvaler bindContext
|
expVal <- evalExp bindContext expr
|
||||||
let
|
let
|
||||||
GraphAndRef expGraph expResult = expVal
|
GraphAndRef expGraph expResult = expVal
|
||||||
newGraph = deleteBindings . makeEdges $ expGraph <> bindGraph
|
newGraph = deleteBindings . makeEdges $ expGraph <> bindGraph
|
||||||
@ -493,30 +394,17 @@ evalGeneralLet expOrRhsEvaler c bs = do
|
|||||||
|
|
||||||
-- END evalGeneralLet
|
-- END evalGeneralLet
|
||||||
|
|
||||||
evalLet :: Show l => EvalContext -> Binds l -> Exp l-> State IDState GraphAndRef
|
evalSelectorAndVal :: Show l =>
|
||||||
evalLet context binds e = evalGeneralLet (`evalExp` e) context binds
|
EvalContext -> SelectorAndVal l -> State IDState (GraphAndRef, GraphAndRef)
|
||||||
|
evalSelectorAndVal c SelectorAndVal{svSelector=sel, svVal=val}
|
||||||
|
= (,) <$> evalExp c sel <*> evalExp c val
|
||||||
|
|
||||||
-- BEGIN rhsWithBinds
|
evalGuard :: Show l =>
|
||||||
|
EvalContext -> [SelectorAndVal l] -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalStmt :: Show l => EvalContext -> Stmt l -> State IDState GraphAndRef
|
evalGuard c selectorsAndVals = let
|
||||||
evalStmt c (Qualifier _ e) = evalExp c e
|
evaledRhss = unzip <$> mapM (evalSelectorAndVal c) selectorsAndVals
|
||||||
evalStmt _ q = error $ "Unsupported syntax in evalStmt: " <> show q
|
|
||||||
|
|
||||||
evalStmts :: Show l => EvalContext -> [Stmt l] -> State IDState GraphAndRef
|
|
||||||
evalStmts c [stmt] = evalStmt c stmt
|
|
||||||
evalStmts _ stmts = error $ "Unsupported syntax in evalStmts: " <> show stmts
|
|
||||||
|
|
||||||
evalGuardedRhs :: Show l =>
|
|
||||||
EvalContext -> GuardedRhs l -> State IDState (GraphAndRef, GraphAndRef)
|
|
||||||
evalGuardedRhs c (GuardedRhs _ stmts e)
|
|
||||||
= (,) <$> evalStmts c stmts <*> evalExp c e
|
|
||||||
|
|
||||||
evalGuardedRhss :: Show l =>
|
|
||||||
EvalContext -> [GuardedRhs l] -> State IDState (SyntaxGraph, NameAndPort)
|
|
||||||
evalGuardedRhss c rhss = let
|
|
||||||
evaledRhss = unzip <$> mapM (evalGuardedRhs c) rhss
|
|
||||||
in
|
in
|
||||||
makeGuardGraph (length rhss)
|
makeGuardGraph (length selectorsAndVals)
|
||||||
<$>
|
<$>
|
||||||
getUniqueName
|
getUniqueName
|
||||||
<*>
|
<*>
|
||||||
@ -524,33 +412,18 @@ evalGuardedRhss c rhss = let
|
|||||||
<*>
|
<*>
|
||||||
fmap snd evaledRhss
|
fmap snd evaledRhss
|
||||||
|
|
||||||
-- | First argument is the right hand side.
|
|
||||||
-- The second arugement is a list of strings that are bound in the environment.
|
|
||||||
evalRhs :: Show l => EvalContext -> Rhs l -> State IDState GraphAndRef
|
|
||||||
evalRhs c (UnGuardedRhs _ e) = evalExp c e
|
|
||||||
evalRhs c (GuardedRhss _ rhss) = grNamePortToGrRef <$> evalGuardedRhss c rhss
|
|
||||||
|
|
||||||
rhsWithBinds :: Show l =>
|
|
||||||
Maybe (Binds l) -> Rhs l -> EvalContext -> State IDState GraphAndRef
|
|
||||||
rhsWithBinds maybeWhereBinds rhs rhsContext = case maybeWhereBinds of
|
|
||||||
Nothing -> evalRhs rhsContext rhs
|
|
||||||
Just b -> evalGeneralLet (`evalRhs` rhs) rhsContext b
|
|
||||||
|
|
||||||
-- END rhsWithBinds
|
|
||||||
|
|
||||||
-- BEGIN evalCase
|
-- BEGIN evalCase
|
||||||
|
|
||||||
-- TODO patRhsAreConnected is sometimes incorrectly true if the pat is just a
|
-- TODO patRhsAreConnected is sometimes incorrectly true if the pat is just a
|
||||||
-- name
|
-- name
|
||||||
evalPatAndRhs :: Show l =>
|
-- returns (combined graph, pattern reference, rhs reference)
|
||||||
|
evalAlt :: Show l =>
|
||||||
EvalContext
|
EvalContext
|
||||||
-> Pat l
|
-> SimpAlt l
|
||||||
-> Rhs l
|
|
||||||
-> Maybe (Binds l)
|
|
||||||
-> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String)
|
-> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String)
|
||||||
evalPatAndRhs c pat rhs maybeWhereBinds = do
|
evalAlt c (SimpAlt pat rhs) = do
|
||||||
((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <-
|
((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <-
|
||||||
bindOrAltHelper c pat rhs maybeWhereBinds
|
bindOrAltHelper c pat rhs
|
||||||
let
|
let
|
||||||
grWithEdges = makeEdges (rhsGraph <> patGraph)
|
grWithEdges = makeEdges (rhsGraph <> patGraph)
|
||||||
lookedUpRhsRef = lookupReference (sgBinds grWithEdges) rhsRef
|
lookedUpRhsRef = lookupReference (sgBinds grWithEdges) rhsRef
|
||||||
@ -567,13 +440,6 @@ evalPatAndRhs c pat rhs maybeWhereBinds = do
|
|||||||
, lookedUpRhsRef
|
, lookedUpRhsRef
|
||||||
, mPatAsName)
|
, mPatAsName)
|
||||||
|
|
||||||
-- returns (combined graph, pattern reference, rhs reference)
|
|
||||||
evalAlt :: Show l =>
|
|
||||||
EvalContext
|
|
||||||
-> Exts.Alt l
|
|
||||||
-> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String)
|
|
||||||
evalAlt c (Exts.Alt _ pat rhs maybeBinds) = evalPatAndRhs c pat rhs maybeBinds
|
|
||||||
|
|
||||||
evalCaseHelper ::
|
evalCaseHelper ::
|
||||||
Int
|
Int
|
||||||
-> NodeName
|
-> NodeName
|
||||||
@ -624,7 +490,8 @@ evalCaseHelper numAlts caseIconName resultIconNames
|
|||||||
|
|
||||||
|
|
||||||
evalCase :: Show l =>
|
evalCase :: Show l =>
|
||||||
EvalContext -> Exp l -> [Alt l] -> State IDState (SyntaxGraph, NameAndPort)
|
EvalContext -> SimpExp l -> [SimpAlt l]
|
||||||
|
-> State IDState (SyntaxGraph, NameAndPort)
|
||||||
evalCase c e alts =
|
evalCase c e alts =
|
||||||
let
|
let
|
||||||
numAlts = length alts
|
numAlts = length alts
|
||||||
@ -641,104 +508,27 @@ evalCase c e alts =
|
|||||||
|
|
||||||
-- END evalCase
|
-- END evalCase
|
||||||
|
|
||||||
evalTuple :: Show l =>
|
|
||||||
EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort)
|
|
||||||
evalTuple c exps =
|
|
||||||
let
|
|
||||||
numExps = length exps
|
|
||||||
in
|
|
||||||
makeApplyGraph numExps ApplyNodeFlavor False
|
|
||||||
<$>
|
|
||||||
getUniqueName
|
|
||||||
<*>
|
|
||||||
(grNamePortToGrRef <$> makeBox (nTupleString numExps))
|
|
||||||
<*>
|
|
||||||
mapM (evalExp c) exps
|
|
||||||
|
|
||||||
evalTupleSection :: Show l =>
|
|
||||||
EvalContext -> [Maybe (Exp l)] -> State IDState (SyntaxGraph, NameAndPort)
|
|
||||||
evalTupleSection c mExps =
|
|
||||||
let
|
|
||||||
exps = catMaybes mExps
|
|
||||||
expIsJustList = fmap isJust mExps
|
|
||||||
in
|
|
||||||
makeApplyGraph (length exps) ApplyNodeFlavor False
|
|
||||||
<$>
|
|
||||||
getUniqueName
|
|
||||||
<*>
|
|
||||||
(grNamePortToGrRef <$> makeBox (nTupleSectionString expIsJustList))
|
|
||||||
<*>
|
|
||||||
mapM (evalExp c) exps
|
|
||||||
|
|
||||||
evalListExp :: Show l =>
|
|
||||||
l -> EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort)
|
|
||||||
evalListExp _ _ [] = makeBox "[]"
|
|
||||||
evalListExp l c exps = evalFunExpAndArgs
|
|
||||||
c
|
|
||||||
ApplyNodeFlavor
|
|
||||||
(makeVarExp l . nListString . length $ exps, exps)
|
|
||||||
|
|
||||||
evalLeftSection :: Show l =>
|
|
||||||
l -> EvalContext -> Exp l -> QOp l -> State IDState GraphAndRef
|
|
||||||
evalLeftSection l c e op = evalExp c $ App l (qOpToExp op) e
|
|
||||||
|
|
||||||
evalRightSection :: Show l =>
|
|
||||||
EvalContext -> QOp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
|
|
||||||
evalRightSection c op e =
|
|
||||||
makeApplyGraph 2 ApplyNodeFlavor False
|
|
||||||
<$>
|
|
||||||
getUniqueName
|
|
||||||
<*>
|
|
||||||
evalExp c (qOpToExp op)
|
|
||||||
<*>
|
|
||||||
((\x y -> [x, y]) <$>
|
|
||||||
-- TODO: A better option would be for makeApplyGraph to take the list of
|
|
||||||
-- expressions as Maybes.
|
|
||||||
fmap (GraphAndRef mempty . Left) (getUniqueString "unusedArgument")
|
|
||||||
<*>
|
|
||||||
evalExp c e
|
|
||||||
)
|
|
||||||
|
|
||||||
-- evalEnums is only used by evalExp
|
|
||||||
evalEnums :: Show l =>
|
|
||||||
l -> EvalContext -> String -> [Exp l] -> State IDState GraphAndRef
|
|
||||||
evalEnums l c s exps
|
|
||||||
= grNamePortToGrRef
|
|
||||||
<$> evalFunExpAndArgs c ApplyNodeFlavor (makeVarExp l s, exps)
|
|
||||||
|
|
||||||
desugarDo :: Show l => [Stmt l] -> Exp l
|
|
||||||
desugarDo [Qualifier _ e] = e
|
|
||||||
desugarDo (Qualifier l e : stmts) = InfixApp l e thenOp (desugarDo stmts)
|
|
||||||
where thenOp = makeQVarOp l ">>"
|
|
||||||
desugarDo (Generator l pat e : stmts) =
|
|
||||||
InfixApp l e (makeQVarOp l ">>=") (Lambda l [pat] (desugarDo stmts))
|
|
||||||
desugarDo (LetStmt l binds : stmts) = Let l binds (desugarDo stmts)
|
|
||||||
desugarDo stmts = error $ "Unsupported syntax in degugarDo: " <> show stmts
|
|
||||||
|
|
||||||
-- TODO: Finish evalRecConstr
|
|
||||||
evalRecConstr :: Show l =>
|
|
||||||
EvalContext -> QName l -> [Exts.FieldUpdate l] -> State IDState GraphAndRef
|
|
||||||
evalRecConstr c qName _ = evalQName qName c
|
|
||||||
|
|
||||||
-- BEGIN generalEvalLambda
|
-- BEGIN generalEvalLambda
|
||||||
|
|
||||||
-- TODO Returning a SyntaxGraph is probably not very efficient
|
-- TODO Returning a SyntaxGraph is probably not very efficient
|
||||||
asBindGraphZipper :: Maybe String -> NameAndPort -> SyntaxGraph
|
asBindGraphZipper :: Maybe String -> NameAndPort -> SyntaxGraph
|
||||||
asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName]
|
asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName]
|
||||||
|
|
||||||
generalEvalLambda :: Show l
|
-- TODO Refactor evalLambda
|
||||||
=> EvalContext
|
evalLambda :: Show l
|
||||||
-> [Pat l]
|
=> l
|
||||||
-> (EvalContext -> State IDState GraphAndRef)
|
-> EvalContext
|
||||||
|
-> [SimpPat l]
|
||||||
|
-> SimpExp l
|
||||||
-> State IDState (SyntaxGraph, NameAndPort)
|
-> State IDState (SyntaxGraph, NameAndPort)
|
||||||
generalEvalLambda context patterns rhsEvalFun = do
|
evalLambda _ context patterns expr = do
|
||||||
lambdaName <- getUniqueName
|
lambdaName <- getUniqueName
|
||||||
patternValsWithAsNames <- mapM evalPattern patterns
|
patternValsWithAsNames <- mapM evalPattern patterns
|
||||||
let
|
let
|
||||||
patternVals = fmap fst patternValsWithAsNames
|
patternVals = fmap fst patternValsWithAsNames
|
||||||
patternStrings = concatMap namesInPattern patternValsWithAsNames
|
patternStrings = concatMap namesInPattern patternValsWithAsNames
|
||||||
rhsContext = patternStrings <> context
|
rhsContext = patternStrings <> context
|
||||||
GraphAndRef rhsRawGraph rhsRef <- rhsEvalFun rhsContext
|
GraphAndRef rhsRawGraph rhsRef <- evalExp rhsContext expr
|
||||||
let
|
let
|
||||||
paramNames = fmap patternName patternValsWithAsNames
|
paramNames = fmap patternName patternValsWithAsNames
|
||||||
enclosedNodeNames = snnName <$> sgNodes combinedGraph
|
enclosedNodeNames = snnName <$> sgNodes combinedGraph
|
||||||
@ -777,99 +567,23 @@ generalEvalLambda context patterns rhsEvalFun = do
|
|||||||
|
|
||||||
-- END generalEvalLambda
|
-- END generalEvalLambda
|
||||||
|
|
||||||
evalLambda :: Show l =>
|
evalExp :: Show l => EvalContext -> SimpExp l -> State IDState GraphAndRef
|
||||||
EvalContext -> [Pat l] -> Exp l -> State IDState (SyntaxGraph, NameAndPort)
|
|
||||||
evalLambda c patterns e = generalEvalLambda c patterns (`evalExp` e)
|
|
||||||
|
|
||||||
evalExp :: Show l => EvalContext -> Exp l -> State IDState GraphAndRef
|
|
||||||
evalExp c x = case x of
|
evalExp c x = case x of
|
||||||
Var _ n -> evalQName n c
|
SeName _ s -> strToGraphRef c s
|
||||||
Con _ n -> evalQName n c
|
SeLit _ lit -> grNamePortToGrRef <$> evalLit lit
|
||||||
Lit _ l -> grNamePortToGrRef <$> evalLit l
|
SeApp _ _ _ -> grNamePortToGrRef <$> evalApp c x
|
||||||
InfixApp l e1 op e2 -> evalInfixApp l c e1 op e2
|
SeLambda l patterns e -> grNamePortToGrRef <$> evalLambda l c patterns e
|
||||||
App l f arg -> grNamePortToGrRef <$> evalApp l c f arg
|
SeLet _ decls expr -> evalLet c decls expr
|
||||||
NegApp l e -> evalExp c (App l (makeVarExp l "negate") e)
|
SeCase _ expr alts -> grNamePortToGrRef <$> evalCase c expr alts
|
||||||
Lambda _ patterns e -> grNamePortToGrRef <$> evalLambda c patterns e
|
SeGuard _ selectorsAndVals -> grNamePortToGrRef <$> evalGuard c selectorsAndVals
|
||||||
Let _ bs e -> evalLet c bs e
|
|
||||||
If _ e1 e2 e3 -> grNamePortToGrRef <$> evalIf c e1 e2 e3
|
|
||||||
Case _ e alts -> grNamePortToGrRef <$> evalCase c e alts
|
|
||||||
Do _ stmts -> evalExp c (desugarDo stmts)
|
|
||||||
-- TODO special tuple symbol
|
|
||||||
Tuple _ _ exps -> grNamePortToGrRef <$> evalTuple c exps
|
|
||||||
TupleSection _ _ mExps -> grNamePortToGrRef <$> evalTupleSection c mExps
|
|
||||||
List l exps -> grNamePortToGrRef <$> evalListExp l c exps
|
|
||||||
Paren _ e -> evalExp c e
|
|
||||||
LeftSection l e op -> evalLeftSection l c e op
|
|
||||||
RightSection _ op e -> grNamePortToGrRef <$> evalRightSection c op e
|
|
||||||
RecConstr _ n updates -> evalRecConstr c n updates
|
|
||||||
-- TODO: Do RecUpdate correcly
|
|
||||||
RecUpdate _ e _ -> evalExp c e
|
|
||||||
EnumFrom l e -> evalEnums l c "enumFrom" [e]
|
|
||||||
EnumFromTo l e1 e2 -> evalEnums l c "enumFromTo" [e1, e2]
|
|
||||||
EnumFromThen l e1 e2 -> evalEnums l c "enumFromThen" [e1, e2]
|
|
||||||
EnumFromThenTo l e1 e2 e3 -> evalEnums l 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
|
|
||||||
|
|
||||||
-- BEGIN evalDecl
|
-- BEGIN evalDecl
|
||||||
|
|
||||||
-- BEGIN evalMatches
|
evalPatBind :: Show l =>
|
||||||
|
l -> EvalContext -> SimpPat l -> SimpExp l -> State IDState SyntaxGraph
|
||||||
-- Only used by matchesToCase
|
evalPatBind _ c pat e = do
|
||||||
matchToAlt :: Show l => Match l -> Alt l
|
|
||||||
matchToAlt (Match l _ mtaPats rhs binds) = Alt l altPattern rhs binds where
|
|
||||||
altPattern = case mtaPats of
|
|
||||||
[onePat] -> onePat
|
|
||||||
_ -> PTuple l Exts.Boxed mtaPats
|
|
||||||
matchToAlt match = error $ "Unsupported syntax in matchToAlt: " <> show match
|
|
||||||
|
|
||||||
matchesToCase :: Show l => Match l -> [Match l] -> Match l
|
|
||||||
matchesToCase match [] = match
|
|
||||||
matchesToCase firstMatch@(Match srcLoc funName pats _ _) restOfMatches = match
|
|
||||||
where
|
|
||||||
-- There is a special case in Icons.hs/makeLabelledPort to exclude " tempvar"
|
|
||||||
-- TODO use a data constructor for the special case instead of using string
|
|
||||||
-- matching for tempvars.
|
|
||||||
tempStrings = fmap (\x -> " tempvar" ++ show x) [0..(length pats - 1)]
|
|
||||||
tempPats = fmap (PVar srcLoc . Ident srcLoc) tempStrings
|
|
||||||
tempVars = fmap (makeVarExp srcLoc) tempStrings
|
|
||||||
tuple = Tuple srcLoc Exts.Boxed tempVars
|
|
||||||
caseExp = case tempVars of
|
|
||||||
[oneTempVar] -> Case srcLoc oneTempVar alts
|
|
||||||
_ -> Case srcLoc tuple alts
|
|
||||||
rhs = UnGuardedRhs srcLoc caseExp
|
|
||||||
match = Match srcLoc funName tempPats rhs Nothing
|
|
||||||
allMatches = firstMatch:restOfMatches
|
|
||||||
alts = fmap matchToAlt allMatches
|
|
||||||
matchesToCase firstMatch _
|
|
||||||
= error $ "Unsupported syntax in matchesToCase: " <> show firstMatch
|
|
||||||
|
|
||||||
evalMatch :: Show l => EvalContext -> Match l -> State IDState SyntaxGraph
|
|
||||||
evalMatch c (Match _ name patterns rhs maybeWhereBinds) = do
|
|
||||||
let
|
|
||||||
matchFunNameString = nameToString name
|
|
||||||
newContext = matchFunNameString : c
|
|
||||||
(lambdaGraph, lambdaPort) <-
|
|
||||||
generalEvalLambda newContext patterns (rhsWithBinds maybeWhereBinds rhs)
|
|
||||||
let
|
|
||||||
newBinding
|
|
||||||
= bindsToSyntaxGraph [SgBind matchFunNameString (Right lambdaPort)]
|
|
||||||
pure $ makeEdges (newBinding <> lambdaGraph)
|
|
||||||
evalMatch _ match = error $ "Unsupported syntax in evalMatch: " <> show match
|
|
||||||
|
|
||||||
evalMatches :: Show l => EvalContext -> [Match l] -> State IDState SyntaxGraph
|
|
||||||
evalMatches _ [] = pure mempty
|
|
||||||
evalMatches c (firstMatch:restOfMatches)
|
|
||||||
= evalMatch c $ matchesToCase firstMatch restOfMatches
|
|
||||||
|
|
||||||
-- END evalMatches
|
|
||||||
|
|
||||||
evalPatBind :: Show l => EvalContext -> Decl l -> State IDState SyntaxGraph
|
|
||||||
evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
|
|
||||||
((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <-
|
((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <-
|
||||||
bindOrAltHelper c pat rhs maybeWhereBinds
|
bindOrAltHelper c pat e
|
||||||
let
|
let
|
||||||
(newEdges, newSinks, bindings) = case patRef of
|
(newEdges, newSinks, bindings) = case patRef of
|
||||||
(Left s) -> (mempty, mempty, [SgBind s rhsRef])
|
(Left s) -> (mempty, mempty, [SgBind s rhsRef])
|
||||||
@ -879,12 +593,13 @@ evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
|
|||||||
asBindGraph = makeAsBindGraph rhsRef [mPatAsName]
|
asBindGraph = makeAsBindGraph rhsRef [mPatAsName]
|
||||||
gr = asBindGraph <> SyntaxGraph mempty newEdges newSinks bindings mempty
|
gr = asBindGraph <> SyntaxGraph mempty newEdges newSinks bindings mempty
|
||||||
pure . makeEdges $ (gr <> rhsGraph <> patGraph)
|
pure . makeEdges $ (gr <> rhsGraph <> patGraph)
|
||||||
evalPatBind _ decl = error $ "Unsupported syntax in evalPatBind: " <> show decl
|
|
||||||
|
|
||||||
-- Pretty printing the entire type sig results in extra whitespace in the middle
|
-- Pretty printing the entire type sig results in extra whitespace in the middle
|
||||||
-- TODO May want to trim whitespace from (prettyPrint typeForNames)
|
-- TODO May want to trim whitespace from (prettyPrint typeForNames)
|
||||||
evalTypeSig :: Show l => Decl l -> State IDState (SyntaxGraph, NameAndPort)
|
evalTypeSig :: Show l =>
|
||||||
evalTypeSig (TypeSig _ names typeForNames) = makeBox
|
[Exts.Name l] -> Exts.Type l
|
||||||
|
-> State IDState (SyntaxGraph, NameAndPort)
|
||||||
|
evalTypeSig names typeForNames = makeBox
|
||||||
(intercalate "," (fmap prettyPrintWithoutNewlines names)
|
(intercalate "," (fmap prettyPrintWithoutNewlines names)
|
||||||
++ " :: "
|
++ " :: "
|
||||||
++ prettyPrintWithoutNewlines typeForNames)
|
++ prettyPrintWithoutNewlines typeForNames)
|
||||||
@ -892,17 +607,12 @@ evalTypeSig (TypeSig _ names typeForNames) = makeBox
|
|||||||
-- TODO Make custom version of prettyPrint for type signitures.
|
-- TODO Make custom version of prettyPrint for type signitures.
|
||||||
-- Use (unwords . words) to convert consecutive whitspace characters to one
|
-- Use (unwords . words) to convert consecutive whitspace characters to one
|
||||||
-- space.
|
-- space.
|
||||||
prettyPrintWithoutNewlines = unwords . words . prettyPrint
|
prettyPrintWithoutNewlines = unwords . words . Exts.prettyPrint
|
||||||
evalTypeSig decl
|
|
||||||
= error $ "Unsupported syntax in evalTypeSig: " <> show decl
|
|
||||||
|
|
||||||
evalDecl :: Show l => EvalContext -> Decl l -> State IDState SyntaxGraph
|
evalDecl :: Show l => EvalContext -> SimpDecl l -> State IDState SyntaxGraph
|
||||||
evalDecl c d = case d of
|
evalDecl c d = case d of
|
||||||
PatBind _ _ _ _ -> evalPatBind c d
|
SdPatBind l pat e -> evalPatBind l c pat e
|
||||||
FunBind _ matches -> evalMatches c matches
|
SdTypeSig _ names typeForNames -> fst <$> evalTypeSig names typeForNames
|
||||||
TypeSig _ _ _ -> fst <$> evalTypeSig d
|
|
||||||
--TODO: Add other cases here
|
|
||||||
_ -> pure mempty
|
|
||||||
|
|
||||||
-- END evalDecl
|
-- END evalDecl
|
||||||
|
|
||||||
@ -923,32 +633,32 @@ showTopLevelBinds gr = do
|
|||||||
newGraph <- mconcat <$> mapM addBind binds
|
newGraph <- mconcat <$> mapM addBind binds
|
||||||
pure $ newGraph <> gr
|
pure $ newGraph <> gr
|
||||||
|
|
||||||
translateDeclToSyntaxGraph :: Show l => Decl l -> SyntaxGraph
|
translateDeclToSyntaxGraph :: Show l => SimpDecl l -> SyntaxGraph
|
||||||
translateDeclToSyntaxGraph d = graph where
|
translateDeclToSyntaxGraph d = graph where
|
||||||
evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds
|
evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds
|
||||||
graph = evalState evaluatedDecl initialIdState
|
graph = evalState evaluatedDecl initialIdState
|
||||||
|
|
||||||
-- | Convert a single function declaration into a SyntaxGraph
|
-- | Convert a single function declaration into a SyntaxGraph
|
||||||
translateStringToSyntaxGraph :: String -> SyntaxGraph
|
translateStringToSyntaxGraph :: String -> SyntaxGraph
|
||||||
translateStringToSyntaxGraph = translateDeclToSyntaxGraph . customParseDecl
|
translateStringToSyntaxGraph = translateDeclToSyntaxGraph . stringToSimpDecl
|
||||||
|
|
||||||
syntaxGraphToCollapsedGraph :: SyntaxGraph -> IngSyntaxGraph FGR.Gr
|
syntaxGraphToCollapsedGraph :: SyntaxGraph -> IngSyntaxGraph FGR.Gr
|
||||||
syntaxGraphToCollapsedGraph = collapseNodes . syntaxGraphToFglGraph
|
syntaxGraphToCollapsedGraph = collapseNodes . syntaxGraphToFglGraph
|
||||||
|
|
||||||
translateDeclToCollapsedGraph :: Show l => Decl l -> IngSyntaxGraph FGR.Gr
|
translateDeclToCollapsedGraph :: Show l => Exts.Decl l -> IngSyntaxGraph FGR.Gr
|
||||||
translateDeclToCollapsedGraph
|
translateDeclToCollapsedGraph
|
||||||
= syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph
|
= syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph . hsDeclToSimpDecl
|
||||||
|
|
||||||
-- Profiling: At one point, this was about 1.5% of total time.
|
-- Profiling: At one point, this was about 1.5% of total time.
|
||||||
translateStringToCollapsedGraphAndDecl ::
|
translateStringToCollapsedGraphAndDecl ::
|
||||||
String -> (IngSyntaxGraph FGR.Gr, Decl Exts.SrcSpanInfo)
|
String -> (IngSyntaxGraph FGR.Gr, Exts.Decl Exts.SrcSpanInfo)
|
||||||
translateStringToCollapsedGraphAndDecl s = (drawing, decl) where
|
translateStringToCollapsedGraphAndDecl s = (drawing, decl) where
|
||||||
decl = customParseDecl s -- :: ParseResult Module
|
decl = customParseDecl s -- :: ParseResult Module
|
||||||
drawing = translateDeclToCollapsedGraph decl
|
drawing = translateDeclToCollapsedGraph decl
|
||||||
|
|
||||||
translateModuleToCollapsedGraphs :: Show l =>
|
translateModuleToCollapsedGraphs :: Show l =>
|
||||||
Module l -> [IngSyntaxGraph FGR.Gr]
|
Exts.Module l -> [IngSyntaxGraph FGR.Gr]
|
||||||
translateModuleToCollapsedGraphs (Module _ _ _ _ decls)
|
translateModuleToCollapsedGraphs (Exts.Module _ _ _ _ decls)
|
||||||
= fmap translateDeclToCollapsedGraph decls
|
= fmap translateDeclToCollapsedGraph decls
|
||||||
translateModuleToCollapsedGraphs moduleSyntax
|
translateModuleToCollapsedGraphs moduleSyntax
|
||||||
= error $ "Unsupported syntax in translateModuleToCollapsedGraphs: "
|
= error $ "Unsupported syntax in translateModuleToCollapsedGraphs: "
|
||||||
|
Loading…
Reference in New Issue
Block a user