glance/app/Translate.hs

151 lines
5.7 KiB
Haskell
Raw Normal View History

{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
module Translate(
translateString
) where
import qualified Diagrams.Prelude as DIA
import Diagrams.Prelude((<>))
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-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)
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]
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)
instance Monoid IconGraph where
2016-02-08 05:01:57 +03:00
mempty = IconGraph [] [] [] []
mappend = (<>)
nameToString :: Language.Haskell.Exts.Name -> String
nameToString (Ident s) = s
nameToString (Symbol s) = s
evalPattern :: Pat -> String
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
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)
-- 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
-- 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"
evalPatBind :: Decl -> IconGraph
2016-02-06 08:07:06 +03:00
evalPatBind (PatBind _ pat rhs _) = graph <> rhsGraph where
patName = evalPattern pat
2016-02-08 05:01:57 +03:00
(rhsGraph, rhsNamePort) = evalRhs rhs []
icons = toNames [
(patName, TextBoxIcon patName)
--(rhsName, TextBoxIcon rhsName)
]
edges = [
-- 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-08 05:01:57 +03:00
evalDecl :: Decl -> Drawing
evalDecl d = iconGraphToDrawing $ case d of
pat@PatBind{} -> evalPatBind pat
2016-02-08 05:01:57 +03:00
FunBind matches -> evalMatches matches
-- 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