git.iko.soy/elk
on 294fdfd help sign in
elk/compiler/Parse/Patterns.hs
104 lines 3.5 kB history raw
2module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where
4import Ast
5import Context
6import Control.Applicative ((<$>),(<*>))
7import Control.Monad
8import Control.Monad.State
9import Data.Char (isUpper)
10import Guid
11import Text.Parsec hiding (newline,spaces,State)
12import Text.Parsec.Indent
13import Parse.Library
15patternBasic :: IParser Pattern
16patternBasic =
17 choice [ char '_' >> return PAnything
18 , do x@(c:_) <- var
19 return $ if isUpper c then PData x [] else PVar x
20 ]
22patternRecord :: IParser Pattern
23patternRecord = PRecord <$> brackets (commaSep1 lowVar)
25patternTuple :: IParser Pattern
26patternTuple = do ps <- parens (commaSep patternExpr)
27 return $ case ps of { [p] -> p; _ -> ptuple ps }
29patternList :: IParser Pattern
30patternList = plist <$> braces (commaSep patternExpr)
32patternTerm :: IParser Pattern
33patternTerm = choice [ patternRecord, patternTuple, patternList, patternBasic ]
34 <?> "pattern"
36patternConstructor :: IParser Pattern
37patternConstructor = PData <$> capVar <*> spacePrefix patternTerm
39patternExpr :: IParser Pattern
40patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"
42makeLambda :: [Pattern] -> CExpr -> GuidCounter CExpr
43makeLambda pats body = go (reverse pats) body
44 where go [] body = return body
45 go (p:ps) body@(C t s _) = do
46 (x,e) <- extract p body
47 go ps (C t s $ Lambda x e)
49extract :: Pattern -> CExpr -> GuidCounter (String, CExpr)
50extract pattern body@(C t s _) =
51 let ctx = C t s in
52 let fn x e = (x,e) in
53 case pattern of
54 PAnything -> return $ fn "_" body
55 PVar x -> return $ fn x body
56 PData name ps -> do
57 x <- guid
58 let a = '_' : show x
59 return . fn a . ctx $ Case (ctx (Var a)) [(pattern, body)]
60 PRecord fs -> do
61 x <- guid
62 let a = '_' : show x
63 toDef f = FnDef f [] (ctx $ Access (ctx $ Var a) f)
64 return . fn a . ctx $ Let (map toDef fs) body
66extracts :: [Pattern] -> CExpr -> GuidCounter ([String], CExpr)
67extracts ps body = go [] (reverse ps) body
68 where go args [] body = return (args, body)
69 go args (p:ps) body = do (x,e) <- extract p body
70 go (x:args) ps e
72flattenPatterns :: [Pattern] -> CExpr -> GuidCounter (IParser [Def])
73flattenPatterns patterns exp@(C t s _) =
74 let ctx = C t s in
75 case patterns of
76 PVar f : args -> do
77 (as,e) <- extracts args exp
78 return . return $
79 if isOp (head f) then let [a,b] = as in [ OpDef f a b e ]
80 else [ FnDef f as e ]
82 [p] -> return `liftM` matchSingle p exp p
84 _ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++
85 ") cannot be used on the left-hand side of an assign statement."
87matchSingle :: Pattern -> CExpr -> Pattern -> GuidCounter [Def]
88matchSingle pat exp@(C t s _) p =
89 let ctx = C t s in
90 case p of
91 PData _ ps -> do x <- guid
92 let v = '_' : show x
93 dss <- mapM (matchSingle pat . ctx $ Var v) ps
94 return (FnDef v [] exp : concat dss)
96 PVar x ->
97 return [ FnDef x [] (ctx $ Case exp [(pat, ctx $ Var x)]) ]
99 PRecord fs -> do
100 a <- (\x -> '_' : show x) `liftM` guid
101 let toDef f = FnDef f [] (ctx $ Access (ctx $ Var a) f)
102 return (FnDef a [] exp : map toDef fs)
104 PAnything -> return []