mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-17 02:40:28 +03:00
Move helper functions from Translate to SimplifySyntax.
This commit is contained in:
parent
b539c18c4e
commit
d39e00e7a1
@ -1,10 +1,14 @@
|
||||
module SimplifySyntax (
|
||||
stringToSimpDecl
|
||||
, qOpToExp
|
||||
, qNameToString
|
||||
, nameToString
|
||||
, customParseDecl
|
||||
) where
|
||||
|
||||
import qualified Language.Haskell.Exts as Exts
|
||||
|
||||
import Translate(qOpToExp, qNameToString, matchesToCase, customParseDecl)
|
||||
import TranslateCore(nTupleString)
|
||||
-- A simplified Haskell syntax tree
|
||||
|
||||
-- rhs is now SimpExp
|
||||
@ -47,6 +51,35 @@ data SimpPat l =
|
||||
| SpAsPat l (Exts.Name l) (SimpPat l)
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- Helper functions
|
||||
|
||||
makeVarExp :: l -> String -> Exts.Exp l
|
||||
makeVarExp l = Exts.Var l . Exts.UnQual l . Exts.Ident l
|
||||
|
||||
qOpToExp :: Exts.QOp l -> Exts.Exp l
|
||||
qOpToExp (Exts.QVarOp l n) = Exts.Var l n
|
||||
qOpToExp (Exts.QConOp l n) = Exts.Con l n
|
||||
|
||||
nameToString :: Exts.Name l -> String
|
||||
nameToString (Exts.Ident _ s) = s
|
||||
nameToString (Exts.Symbol _ s) = s
|
||||
|
||||
-- TODO refactor qNameToString
|
||||
qNameToString :: Show l => Exts.QName l -> String
|
||||
qNameToString (Exts.Qual _ (Exts.ModuleName _ modName) name)
|
||||
= modName ++ "." ++ nameToString name
|
||||
qNameToString (Exts.UnQual _ name) = nameToString name
|
||||
qNameToString (Exts.Special _ (Exts.UnitCon _)) = "()"
|
||||
qNameToString (Exts.Special _ (Exts.ListCon _)) = "[]"
|
||||
qNameToString (Exts.Special _ (Exts.FunCon _)) = "(->)"
|
||||
qNameToString (Exts.Special _ (Exts.TupleCon _ _ n)) = nTupleString n
|
||||
qNameToString (Exts.Special _ (Exts.Cons _)) = "(:)"
|
||||
-- unboxed singleton tuple constructor
|
||||
qNameToString (Exts.Special _ (Exts.UnboxedSingleCon _)) = "(# #)"
|
||||
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
|
||||
@ -88,6 +121,36 @@ matchToFunBind (Exts.Match l name patterns rhs maybeWhereBinds)
|
||||
(whereToLet l rhs maybeWhereBinds)
|
||||
matchToFunBind m = error $ "Unsupported syntax in matchToFunBind: " <> show m
|
||||
|
||||
-- Only used by matchesToCase
|
||||
matchToAlt :: Show l => Exts.Match l -> Exts.Alt l
|
||||
matchToAlt (Exts.Match l _ mtaPats rhs binds) = Exts.Alt l altPattern rhs binds where
|
||||
altPattern = case mtaPats of
|
||||
[onePat] -> onePat
|
||||
_ -> Exts.PTuple l Exts.Boxed mtaPats
|
||||
matchToAlt match = error $ "Unsupported syntax in matchToAlt: " <> show match
|
||||
|
||||
-- TODO Refactor matchesToCase
|
||||
matchesToCase :: Show l => Exts.Match l -> [Exts.Match l] -> Exts.Match l
|
||||
matchesToCase match [] = match
|
||||
matchesToCase firstMatch@(Exts.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 (Exts.PVar srcLoc . Exts.Ident srcLoc) tempStrings
|
||||
tempVars = fmap (makeVarExp srcLoc) tempStrings
|
||||
tuple = Exts.Tuple srcLoc Exts.Boxed tempVars
|
||||
caseExp = case tempVars of
|
||||
[oneTempVar] -> Exts.Case srcLoc oneTempVar alts
|
||||
_ -> Exts.Case srcLoc tuple alts
|
||||
rhs = Exts.UnGuardedRhs srcLoc caseExp
|
||||
match = Exts.Match srcLoc funName tempPats rhs Nothing
|
||||
allMatches = firstMatch:restOfMatches
|
||||
alts = fmap matchToAlt allMatches
|
||||
matchesToCase firstMatch _
|
||||
= error $ "Unsupported syntax in matchesToCase: " <> show firstMatch
|
||||
|
||||
matchesToFunBind :: Show a => a -> [Exts.Match a] -> SimpDecl a
|
||||
matchesToFunBind l matches = case matches of
|
||||
[] -> error $ "Empty matches in matchesToFunBind. Label is :" <> show l
|
||||
@ -153,5 +216,17 @@ hsExpToSimpExp x = case x of
|
||||
|
||||
-- Parsing
|
||||
|
||||
customParseMode :: Exts.ParseMode
|
||||
customParseMode = Exts.defaultParseMode
|
||||
{Exts.extensions =
|
||||
[Exts.EnableExtension Exts.MultiParamTypeClasses,
|
||||
Exts.EnableExtension Exts.FlexibleContexts,
|
||||
Exts.EnableExtension Exts.TupleSections
|
||||
]
|
||||
}
|
||||
|
||||
customParseDecl :: String -> Exts.Decl Exts.SrcSpanInfo
|
||||
customParseDecl = Exts.fromParseResult . Exts.parseDeclWithMode customParseMode
|
||||
|
||||
stringToSimpDecl :: String -> SimpDecl Exts.SrcSpanInfo
|
||||
stringToSimpDecl = hsDeclToSimpDecl . customParseDecl
|
||||
|
@ -21,11 +21,14 @@ import Data.Maybe(catMaybes, isJust, fromMaybe)
|
||||
import qualified Language.Haskell.Exts as Exts
|
||||
|
||||
import Language.Haskell.Exts(
|
||||
Decl(..), parseDeclWithMode, Name(..), Pat(..), Rhs(..),
|
||||
Exp(..), QName(..), fromParseResult, Match(..), QOp(..), GuardedRhs(..),
|
||||
Stmt(..), Binds(..), Alt(..), Module(..), SpecialCon(..), prettyPrint)
|
||||
Decl(..), Name(..), Pat(..), Rhs(..),
|
||||
Exp(..), QName(..), Match(..), QOp(..), GuardedRhs(..),
|
||||
Stmt(..), Binds(..), Alt(..), Module(..), prettyPrint)
|
||||
|
||||
import GraphAlgorithms(collapseNodes)
|
||||
import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts,
|
||||
casePatternPorts)
|
||||
import SimplifySyntax(qOpToExp, qNameToString, nameToString, customParseDecl)
|
||||
import TranslateCore(
|
||||
Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..), SgSink(..),
|
||||
syntaxGraphFromNodes, syntaxGraphFromNodesEdges, getUniqueName,
|
||||
@ -39,8 +42,6 @@ import Types(Labeled(..), NameAndPort(..), IDState,
|
||||
Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, SgNamedNode(..),
|
||||
LikeApplyFlavor(..))
|
||||
import Util(makeSimpleEdge, nameAndPort, justName)
|
||||
import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts,
|
||||
casePatternPorts)
|
||||
|
||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||
|
||||
@ -57,10 +58,6 @@ makeVarExp l = Var l . UnQual l . Ident l
|
||||
makeQVarOp :: l -> String -> QOp l
|
||||
makeQVarOp l = QVarOp l . UnQual l . Ident l
|
||||
|
||||
qOpToExp :: QOp l -> Exp l
|
||||
qOpToExp (QVarOp l n) = Var l n
|
||||
qOpToExp (QConOp l n) = Con l n
|
||||
|
||||
-- | Make a syntax graph that has the bindings for a list of "as pattern" (@)
|
||||
-- names.
|
||||
makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph
|
||||
@ -97,27 +94,6 @@ patternName (GraphAndRef _ ref, mStr) = fromMaybe
|
||||
|
||||
-- END Helper Functions --
|
||||
|
||||
-- BEGIN Names helper functions --
|
||||
|
||||
nameToString :: Exts.Name l -> String
|
||||
nameToString (Ident _ s) = s
|
||||
nameToString (Symbol _ s) = s
|
||||
|
||||
qNameToString :: Show l => QName l -> String
|
||||
qNameToString (Qual _ (Exts.ModuleName _ modName) name)
|
||||
= modName ++ "." ++ nameToString name
|
||||
qNameToString (UnQual _ name) = nameToString name
|
||||
qNameToString (Special _ (UnitCon _)) = "()"
|
||||
qNameToString (Special _ (ListCon _)) = "[]"
|
||||
qNameToString (Special _ (FunCon _)) = "(->)"
|
||||
qNameToString (Special _ (TupleCon _ _ n)) = nTupleString n
|
||||
qNameToString (Special _ (Cons _)) = "(:)"
|
||||
-- unboxed singleton tuple constructor
|
||||
qNameToString (Special _ (UnboxedSingleCon _)) = "(# #)"
|
||||
qNameToString q = error $ "Unsupported syntax in qNameToSrting: " <> show q
|
||||
|
||||
-- END Names helper functions
|
||||
|
||||
-- BEGIN evalLit
|
||||
|
||||
-- This is in Translate and not Translate core since currently it is only used
|
||||
@ -952,18 +928,6 @@ translateDeclToSyntaxGraph d = graph where
|
||||
evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds
|
||||
graph = evalState evaluatedDecl initialIdState
|
||||
|
||||
customParseMode :: Exts.ParseMode
|
||||
customParseMode = Exts.defaultParseMode
|
||||
{Exts.extensions =
|
||||
[Exts.EnableExtension Exts.MultiParamTypeClasses,
|
||||
Exts.EnableExtension Exts.FlexibleContexts,
|
||||
Exts.EnableExtension Exts.TupleSections
|
||||
]
|
||||
}
|
||||
|
||||
customParseDecl :: String -> Decl Exts.SrcSpanInfo
|
||||
customParseDecl = fromParseResult . parseDeclWithMode customParseMode
|
||||
|
||||
-- | Convert a single function declaration into a SyntaxGraph
|
||||
translateStringToSyntaxGraph :: String -> SyntaxGraph
|
||||
translateStringToSyntaxGraph = translateDeclToSyntaxGraph . customParseDecl
|
||||
|
11
glance.cabal
11
glance.cabal
@ -46,7 +46,15 @@ executable glance-exe
|
||||
, svg-builder
|
||||
, optparse-applicative
|
||||
default-language: Haskell2010
|
||||
Other-modules: Icons, Rendering, Types, Util, Translate, TranslateCore, DrawingColors, GraphAlgorithms
|
||||
Other-modules: Icons
|
||||
, Rendering
|
||||
, Types
|
||||
, Util
|
||||
, Translate
|
||||
, TranslateCore
|
||||
, DrawingColors
|
||||
, GraphAlgorithms
|
||||
, SimplifySyntax
|
||||
|
||||
test-suite glance-test
|
||||
type: exitcode-stdio-1.0
|
||||
@ -87,6 +95,7 @@ test-suite glance-test
|
||||
, TranslateCore
|
||||
, DrawingColors
|
||||
, GraphAlgorithms
|
||||
, SimplifySyntax
|
||||
|
||||
|
||||
source-repository head
|
||||
|
Loading…
Reference in New Issue
Block a user