mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +03:00
Remove state from matchesToCase.
This commit is contained in:
parent
3b55075fd5
commit
ee53213252
@ -57,11 +57,51 @@ infixAppToSeApp l e1 op e2 = case op of
|
||||
hsPatToSimpPat :: Exts.Pat a -> SimpPat a
|
||||
hsPatToSimpPat = undefined
|
||||
|
||||
hsBindsToDecls :: Exts.Binds a -> [SimpDecl a]
|
||||
hsBindsToDecls = undefined
|
||||
whereToLet :: Show a => a -> Exts.Rhs a -> Maybe (Exts.Binds a) -> SimpExp a
|
||||
whereToLet l rhs maybeBinds = val
|
||||
where
|
||||
rhsExp = hsRhsToExp rhs
|
||||
val = case maybeBinds of
|
||||
Nothing -> rhsExp
|
||||
Just binds -> SeLet l (hsBindsToDecls binds) rhsExp
|
||||
|
||||
hsAltToSimpAlt :: Exts.Alt a -> SimpAlt a
|
||||
hsAltToSimpAlt = undefined
|
||||
matchesToLambda :: a -> [Exts.Match a] -> SimpDecl a
|
||||
matchesToLambda = undefined
|
||||
|
||||
hsDeclToSimpDecl :: Show a => Exts.Decl a -> SimpDecl a
|
||||
hsDeclToSimpDecl decl = case decl of
|
||||
Exts.FunBind l matches -> matchesToLambda l matches
|
||||
Exts.PatBind l pat rhs maybeBinds -> SdPatBind l (hsPatToSimpPat pat) expr
|
||||
where
|
||||
expr = whereToLet l rhs maybeBinds
|
||||
-- TODO Exts.TypeSig
|
||||
_ -> error $ "Unsupported syntax in hsDeclToSimpDecl: " ++ show decl
|
||||
|
||||
hsBindsToDecls :: Show a => Exts.Binds a -> [SimpDecl a]
|
||||
hsBindsToDecls binds = case binds of
|
||||
Exts.BDecls _ decls -> fmap hsDeclToSimpDecl decls
|
||||
_ -> error $ "Unsupported syntax in hsBindsToDecls: " ++ show binds
|
||||
|
||||
guardedRhsToSelectorAndVal :: Show a => Exts.GuardedRhs a -> SelectorAndVal a
|
||||
guardedRhsToSelectorAndVal rhs = case rhs of
|
||||
Exts.GuardedRhs _ [s] valExp -> SelectorAndVal{svSelector=stmtToExp s
|
||||
, svVal=hsExpToSimpExp valExp}
|
||||
_ -> error $ "Unsupported syntax in guardedRhsToSelectorAndVal: " ++ show rhs
|
||||
where
|
||||
stmtToExp stmt = case stmt of
|
||||
Exts.Qualifier _ e -> hsExpToSimpExp e
|
||||
_ -> error
|
||||
$ "Unsupported syntax in stmtToExp: " ++ show stmt
|
||||
|
||||
hsRhsToExp :: Show a => Exts.Rhs a -> SimpExp a
|
||||
hsRhsToExp rhs = case rhs of
|
||||
Exts.UnGuardedRhs _ e -> hsExpToSimpExp e
|
||||
Exts.GuardedRhss l rhss
|
||||
-> SeGuard l (fmap guardedRhsToSelectorAndVal rhss)
|
||||
|
||||
hsAltToSimpAlt :: Show a => Exts.Alt a -> SimpAlt a
|
||||
hsAltToSimpAlt (Exts.Alt l pat rhs maybeBinds)
|
||||
= SimpAlt{saPat=hsPatToSimpPat pat, saVal=whereToLet l rhs maybeBinds}
|
||||
|
||||
ifToGuard :: a -> SimpExp a -> SimpExp a -> SimpExp a -> SimpExp a
|
||||
ifToGuard l e1 e2 e3
|
||||
|
@ -847,12 +847,12 @@ matchToAlt (Match l _ mtaPats rhs binds) = Alt l altPattern rhs binds where
|
||||
_ -> PTuple l Exts.Boxed mtaPats
|
||||
matchToAlt match = error $ "Unsupported syntax in matchToAlt: " <> show match
|
||||
|
||||
matchesToCase :: Show l => Match l -> [Match l] -> State IDState (Match l)
|
||||
matchesToCase match [] = pure match
|
||||
matchesToCase firstMatch@(Match srcLoc funName pats _ _) restOfMatches = do
|
||||
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"
|
||||
tempStrings <- replicateM (length pats) (getUniqueString " tempvar")
|
||||
let
|
||||
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
|
||||
@ -861,8 +861,6 @@ matchesToCase firstMatch@(Match srcLoc funName pats _ _) restOfMatches = do
|
||||
_ -> Case srcLoc tuple alts
|
||||
rhs = UnGuardedRhs srcLoc caseExp
|
||||
match = Match srcLoc funName tempPats rhs Nothing
|
||||
pure match
|
||||
where
|
||||
allMatches = firstMatch:restOfMatches
|
||||
alts = fmap matchToAlt allMatches
|
||||
matchesToCase firstMatch _
|
||||
@ -884,7 +882,7 @@ 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)
|
||||
= matchesToCase firstMatch restOfMatches >>= evalMatch c
|
||||
= evalMatch c $ matchesToCase firstMatch restOfMatches
|
||||
|
||||
-- END evalMatches
|
||||
|
||||
|
@ -191,7 +191,8 @@ lambdaTests = [
|
||||
"y x = f x1 x2",
|
||||
"y (-1) = 2",
|
||||
"y 1 = 0",
|
||||
"y x = z 3 where z = f x y"
|
||||
"y x = z 3 where z = f x y",
|
||||
"y (Foo x) = x; y (Bar x) = 3" -- test multiple matches
|
||||
]
|
||||
|
||||
letTests :: [String]
|
||||
|
Loading…
Reference in New Issue
Block a user