2016-02-04 11:19:08 +03:00
|
|
|
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
|
|
|
|
module Translate(
|
|
|
|
translateString
|
|
|
|
) where
|
|
|
|
|
|
|
|
import qualified Diagrams.Prelude as DIA
|
2016-02-05 08:53:21 +03:00
|
|
|
import Diagrams.Prelude((<>))
|
2016-02-04 11:19:08 +03:00
|
|
|
|
2016-02-05 08:53:21 +03:00
|
|
|
import Language.Haskell.Exts(Decl(..), parseDecl,
|
2016-02-08 05:01:57 +03:00
|
|
|
Name(..), Pat(..), Rhs(..), Exp(..), QName(..), fromParseResult, Match(..)) --(parseFile, parse, ParseResult, Module)
|
2016-02-06 08:07:06 +03:00
|
|
|
import Control.Monad.State(State, evalState)
|
2016-02-08 05:01:57 +03:00
|
|
|
import Data.List(elemIndex)
|
2016-02-04 11:19:08 +03:00
|
|
|
|
2016-02-08 05:01:57 +03:00
|
|
|
import Types(Icon, Edge(..), Drawing(..), NameAndPort(..), IDState,
|
2016-02-06 08:07:06 +03:00
|
|
|
initialIdState, getId)
|
2016-02-08 05:01:57 +03:00
|
|
|
import Util(toNames, noEnds, nameAndPort, justName, fromMaybeError)
|
2016-02-04 11:19:08 +03:00
|
|
|
import Icons(Icon(..))
|
|
|
|
|
2016-02-08 05:01:57 +03:00
|
|
|
data IconGraph = IconGraph [(DIA.Name, Icon)] [Edge] [(DIA.Name, Drawing)] [(String, NameAndPort)]
|
|
|
|
|
|
|
|
type EvalContext = [String]
|
2016-02-05 08:53:21 +03:00
|
|
|
|
|
|
|
instance DIA.Semigroup IconGraph where
|
2016-02-08 05:01:57 +03:00
|
|
|
(IconGraph icons1 edges1 subDrawings1 context1) <> (IconGraph icons2 edges2 subDrawings2 context2) =
|
|
|
|
IconGraph (icons1 <> icons2) (edges1 <> edges2) (subDrawings1 <> subDrawings2) (context1 <> context2)
|
2016-02-05 08:53:21 +03:00
|
|
|
|
|
|
|
instance Monoid IconGraph where
|
2016-02-08 05:01:57 +03:00
|
|
|
mempty = IconGraph [] [] [] []
|
2016-02-05 08:53:21 +03:00
|
|
|
mappend = (<>)
|
|
|
|
|
|
|
|
nameToString :: Language.Haskell.Exts.Name -> String
|
2016-02-04 11:19:08 +03:00
|
|
|
nameToString (Ident s) = s
|
|
|
|
nameToString (Symbol s) = s
|
|
|
|
|
2016-02-05 08:53:21 +03:00
|
|
|
evalPattern :: Pat -> String
|
2016-02-04 11:19:08 +03:00
|
|
|
evalPattern p = case p of
|
|
|
|
PVar n -> nameToString n
|
|
|
|
-- TODO other cases
|
|
|
|
|
2016-02-08 05:01:57 +03:00
|
|
|
evalQName :: QName -> EvalContext -> Either String (IconGraph, NameAndPort)
|
|
|
|
evalQName (UnQual n) context = result where
|
2016-02-05 08:53:21 +03:00
|
|
|
nameString = nameToString n
|
2016-02-08 05:01:57 +03:00
|
|
|
graph = IconGraph [(DIA.toName nameString, TextBoxIcon nameString)] [] [] []
|
|
|
|
result = if nameString `elem` context
|
|
|
|
then Left nameString
|
|
|
|
else Right (graph, justName nameString)
|
2016-02-04 11:19:08 +03:00
|
|
|
-- TODO other cases
|
|
|
|
|
2016-02-08 05:01:57 +03:00
|
|
|
evalApp :: Exp -> Exp -> EvalContext -> State IDState (Either String (IconGraph, NameAndPort))
|
|
|
|
evalApp exp1 exp2 s = do -- State Monad
|
|
|
|
funVal <- evalExp exp1 s
|
|
|
|
argVal <- evalExp exp2 s
|
2016-02-06 08:07:06 +03:00
|
|
|
newId <- getId
|
|
|
|
let
|
2016-02-08 05:01:57 +03:00
|
|
|
functionPort = nameAndPort applyIconName 0
|
|
|
|
(funGr, funEdges, funBoundVars) = case funVal of
|
|
|
|
Left s' -> (mempty, [], [(s', functionPort)])
|
|
|
|
Right (fGr, funNamePort) -> (fGr, [Edge (funNamePort, functionPort) noEnds], [])
|
|
|
|
argumentPort = nameAndPort applyIconName 1
|
|
|
|
(argGr, argEdges, argBoundVars) = case argVal of
|
|
|
|
Left s' -> (mempty, [], [(s', argumentPort)])
|
|
|
|
Right (aGr, argNamePort) -> (aGr, [Edge (argNamePort, argumentPort) noEnds], [])
|
|
|
|
newGraph = IconGraph icons (funEdges <> argEdges) [] (funBoundVars <> argBoundVars)
|
2016-02-06 08:07:06 +03:00
|
|
|
applyIconString = "app0" ++ show newId
|
|
|
|
applyIconName = DIA.toName applyIconString
|
|
|
|
icons = [(applyIconName, Apply0Icon)]
|
2016-02-08 05:01:57 +03:00
|
|
|
pure $ Right (newGraph <> funGr <> argGr, nameAndPort applyIconName 2)
|
2016-02-06 08:07:06 +03:00
|
|
|
|
2016-02-08 05:01:57 +03:00
|
|
|
evalExp :: Exp -> EvalContext -> State IDState (Either String (IconGraph, NameAndPort))
|
|
|
|
evalExp x c = case x of
|
|
|
|
Var n -> pure $ evalQName n c
|
|
|
|
App exp1 exp2 -> evalApp exp1 exp2 c
|
|
|
|
Paren e -> evalExp e c
|
2016-02-04 11:19:08 +03:00
|
|
|
-- TODO other cases
|
|
|
|
|
2016-02-08 05:01:57 +03:00
|
|
|
-- | First argument is the right hand side.
|
|
|
|
-- The second arugement is a list of strings that are bound in the environment.
|
|
|
|
evalRhs :: Rhs -> EvalContext -> (IconGraph, NameAndPort)
|
|
|
|
evalRhs (UnGuardedRhs e) scope = case evalState (evalExp e scope) initialIdState of
|
|
|
|
Left _ -> error "rhs result expression is a bound var."
|
|
|
|
Right x -> x
|
|
|
|
evalRhs (GuardedRhss _) _ = error "GuardedRhss not implemented"
|
2016-02-04 11:19:08 +03:00
|
|
|
|
2016-02-05 08:53:21 +03:00
|
|
|
evalPatBind :: Decl -> IconGraph
|
2016-02-06 08:07:06 +03:00
|
|
|
evalPatBind (PatBind _ pat rhs _) = graph <> rhsGraph where
|
2016-02-04 11:19:08 +03:00
|
|
|
patName = evalPattern pat
|
2016-02-08 05:01:57 +03:00
|
|
|
(rhsGraph, rhsNamePort) = evalRhs rhs []
|
2016-02-04 11:19:08 +03:00
|
|
|
icons = toNames [
|
2016-02-05 08:53:21 +03:00
|
|
|
(patName, TextBoxIcon patName)
|
|
|
|
--(rhsName, TextBoxIcon rhsName)
|
2016-02-04 11:19:08 +03:00
|
|
|
]
|
|
|
|
edges = [
|
2016-02-05 08:53:21 +03:00
|
|
|
-- TODO use port here
|
|
|
|
Edge (justName patName, rhsNamePort) noEnds
|
|
|
|
]
|
2016-02-08 05:01:57 +03:00
|
|
|
graph = IconGraph icons edges [] []
|
|
|
|
|
|
|
|
iconGraphToDrawing :: IconGraph -> Drawing
|
|
|
|
iconGraphToDrawing (IconGraph icons edges subDrawings _) = Drawing icons edges subDrawings
|
|
|
|
|
|
|
|
evalMatch :: Match -> IconGraph
|
|
|
|
evalMatch (Match _ name patterns _ rhs _) = drawing
|
|
|
|
where
|
|
|
|
-- TODO unique names for lambdaName and resultName
|
|
|
|
nameString = nameToString name
|
|
|
|
patternStrings = map evalPattern patterns
|
|
|
|
numParameters = length patternStrings
|
|
|
|
(rhsGraph, rhsResult) = evalRhs rhs patternStrings
|
|
|
|
resultName = "res"
|
|
|
|
rhsNewIcons = toNames [(resultName, ResultIcon)]
|
|
|
|
rhsNewEdges = [Edge (rhsResult, justName resultName) noEnds]
|
|
|
|
rhsGraphWithResult = rhsGraph <> IconGraph rhsNewIcons rhsNewEdges [] []
|
|
|
|
rhsDrawing = iconGraphToDrawing rhsGraphWithResult
|
|
|
|
rhsDrawingName = DIA.toName "rhsDraw"
|
|
|
|
lambdaName = "lam"
|
|
|
|
|
|
|
|
icons = toNames [
|
|
|
|
(lambdaName, LambdaRegionIcon numParameters rhsDrawingName),
|
|
|
|
(nameString, TextBoxIcon nameString)
|
|
|
|
]
|
|
|
|
(IconGraph _ _ _ boundVars) = rhsGraph
|
|
|
|
|
|
|
|
qualifyNameAndPort :: String -> NameAndPort -> NameAndPort
|
|
|
|
qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p
|
|
|
|
|
|
|
|
boundVarsToEdge (s, np) = Edge (source, qualifyNameAndPort lambdaName np) noEnds
|
|
|
|
where
|
|
|
|
source = nameAndPort lambdaName
|
|
|
|
(fromMaybeError "boundVar not found" (elemIndex s patternStrings))
|
|
|
|
externalEdges = [Edge (justName nameString, justName lambdaName) noEnds]
|
|
|
|
internalEdges = boundVarsToEdge <$> filter (\(s, _) -> s `elem` patternStrings) boundVars
|
|
|
|
drawing = IconGraph icons (externalEdges <> internalEdges) [(rhsDrawingName, rhsDrawing)] []
|
|
|
|
|
|
|
|
|
|
|
|
evalMatches :: [Match] -> IconGraph
|
|
|
|
evalMatches [] = IconGraph [] [] [] []
|
|
|
|
evalMatches [match] = evalMatch match
|
|
|
|
-- TODO turn more than one match into a case expression.
|
2016-02-04 11:19:08 +03:00
|
|
|
|
2016-02-08 05:01:57 +03:00
|
|
|
evalDecl :: Decl -> Drawing
|
|
|
|
evalDecl d = iconGraphToDrawing $ case d of
|
2016-02-04 11:19:08 +03:00
|
|
|
pat@PatBind{} -> evalPatBind pat
|
2016-02-08 05:01:57 +03:00
|
|
|
FunBind matches -> evalMatches matches
|
2016-02-04 11:19:08 +03:00
|
|
|
-- TODO other cases
|
|
|
|
|
|
|
|
translateString :: String -> (Drawing, Decl)
|
|
|
|
translateString s = (drawing, decl) where
|
|
|
|
parseResult = parseDecl s -- :: ParseResult Module
|
|
|
|
decl = fromParseResult parseResult
|
2016-02-08 05:01:57 +03:00
|
|
|
drawing = evalDecl decl
|