git.iko.soy/elk
on a3801ac help sign in
elk/compiler/Parse/Patterns.hs
124 lines 4.1 kB history raw
2module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where
4import Ast
5import Located
6import Control.Applicative ((<$>),(<*>),(*>),pure)
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 ]
22asPattern :: IParser Pattern -> IParser Pattern
23asPattern pattern = do
24 p <- pattern
25 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
26 return $ case var of
27 Just v -> PAsVar v p
28 Nothing -> p
30patternRecord :: IParser Pattern
31patternRecord = PRecord <$> brackets (commaSep1 lowVar)
33patternTuple :: IParser Pattern
34patternTuple = do ps <- parens (commaSep patternExpr)
35 return $ case ps of { [p] -> p; _ -> ptuple ps }
37patternList :: IParser Pattern
38patternList = plist <$> braces (commaSep patternExpr)
40patternTerm :: IParser Pattern
41patternTerm = (choice [ patternRecord, patternTuple, patternList,
42 patternBasic ])
43 <?> "pattern"
45patternConstructor :: IParser Pattern
46patternConstructor = PData <$> capVar <*> spacePrefix patternTerm
48patternExpr :: IParser Pattern
49patternExpr =
50 asPattern (foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm))
51 <?> "pattern"
53makeLambda :: [Pattern] -> CExpr -> GuidCounter CExpr
54makeLambda pats body = go (reverse pats) body
55 where go [] body = return body
56 go (p:ps) body@(L t s _) = do
57 (x,e) <- extract p body
58 go ps (L t s $ Lambda x e)
60extract :: Pattern -> CExpr -> GuidCounter (String, CExpr)
61extract pattern body@(L t s _) =
62 let loc = L t s in
63 let fn x e = (x,e) in
64 case pattern of
65 PAnything -> return $ fn "_" body
66 PVar x -> return $ fn x body
67 PAsVar x PAnything -> return $ fn x body
68 PAsVar x p -> do
69 (x', body') <- extract p body
70 return $ fn x (loc $ Let [FnDef x' [] (loc $ Var x)] body')
71 PData name ps -> do
72 x <- guid
73 let a = '_' : show x
74 return . fn a . loc $ Case (loc (Var a)) [(pattern, body)]
75 PRecord fs -> do
76 x <- guid
77 let a = '_' : show x
78 toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
79 return . fn a . loc $ Let (map toDef fs) body
81extracts :: [Pattern] -> CExpr -> GuidCounter ([String], CExpr)
82extracts ps body = go [] (reverse ps) body
83 where go args [] body = return (args, body)
84 go args (p:ps) body = do (x,e) <- extract p body
85 go (x:args) ps e
87flattenPatterns :: [Pattern] -> CExpr -> GuidCounter (IParser [Def])
88flattenPatterns patterns exp@(L t s _) =
89 let loc = L t s in
90 case patterns of
91 PVar f : args -> do
92 (as,e) <- extracts args exp
93 return . return $
94 if isOp (head f) then let [a,b] = as in [ OpDef f a b e ]
95 else [ FnDef f as e ]
97 [p] -> return `liftM` matchSingle p exp p
99 _ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++
100 ") cannot be used on the left-hand side of an assign statement."
102matchSingle :: Pattern -> CExpr -> Pattern -> GuidCounter [Def]
103matchSingle pat exp@(L t s _) p =
104 let loc = L t s in
105 case p of
106 PData _ ps -> do
107 x <- guid
108 let v = '_' : show x
109 dss <- mapM (matchSingle pat . loc $ Var v) ps
110 return (FnDef v [] exp : concat dss)
112 PVar x ->
113 return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]
115 PAsVar x p' -> do
116 subPat <- matchSingle p' (loc $ Var x) p'
117 return $ (FnDef x [] (loc $ Case exp [(pat, loc $ Var x)])):subPat
119 PRecord fs -> do
120 a <- (\x -> '_' : show x) `liftM` guid
121 let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
122 return (FnDef a [] exp : map toDef fs)
124 PAnything -> return []