git.iko.soy/elk
on 727d708 help sign in
elk/compiler/Parse/Pattern.hs
134 lines 4.3 kB history raw
2module Parse.Pattern (term, expr) where
4import Control.Applicative ((<$>),(<*>),pure)
5import Control.Monad
6import Control.Monad.State
7import Data.Char (isUpper)
8import Data.List (intercalate)
9import Unique
10import Text.Parsec hiding (newline,spaces,State)
11import Text.Parsec.Indent
13import Parse.Helpers
14import Parse.Literal
15import qualified SourceSyntax.Pattern as Pattern
16import SourceSyntax.Everything hiding (parens, tuple)
19basic :: IParser Pattern
20basic = choice
21 [ char '_' >> return PAnything
22 , do v <- var
23 return $ case v of
24 "True" -> PLiteral (Boolean True)
25 "False" -> PLiteral (Boolean False)
26 c : _ -> if isUpper c then PData v [] else PVar v
27 , do lit <- literal
28 return $ case lit of
29 Str s -> foldr combine (PData "[]" []) s
30 where combine h t = PData "::" [PLiteral (Chr h),t]
31 _ -> PLiteral lit
32 ]
34asPattern :: Pattern -> IParser Pattern
35asPattern pattern = do
36 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
37 return $ case var of
38 Just v -> PAlias v pattern
39 Nothing -> pattern
41record :: IParser Pattern
42record = PRecord <$> brackets (commaSep1 lowVar)
44tuple :: IParser Pattern
45tuple = do ps <- parens (commaSep expr)
46 return $ case ps of { [p] -> p; _ -> Pattern.tuple ps }
48list :: IParser Pattern
49list = Pattern.list <$> braces (commaSep expr)
51term :: IParser Pattern
52term =
53 (choice [ record, tuple, list, basic ]) <?> "pattern"
55patternConstructor :: IParser Pattern
56patternConstructor = do
57 v <- intercalate "." <$> dotSep1 capVar
58 case v of
59 "True" -> return $ PLiteral (Boolean True)
60 "False" -> return $ PLiteral (Boolean False)
61 _ -> PData v <$> spacePrefix term
63expr :: IParser Pattern
64expr = do
65 patterns <- consSep1 (patternConstructor <|> term)
66 asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
68{--
69extract :: Pattern -> LExpr t v -> Unique (String, LExpr t v)
70extract pattern body@(L t s _) =
71 let loc = L t s in
72 let fn x e = (x,e) in
73 case pattern of
74 PAnything -> return $ fn "_" body
75 PVar x -> return $ fn x body
76 PAlias x PAnything -> return $ fn x body
77 PAlias x p -> do
78 (x', body') <- extract p body
79 return $ fn x (loc $ Let [FnDef x' [] (loc $ Var x)] body')
80 PData name ps -> do
81 x <- guid
82 let a = '_' : show x
83 return . fn a . loc $ Case (loc (Var a)) [(pattern, body)]
84 PRecord fs -> do
85 x <- guid
86 let a = '_' : show x
87 toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
88 return . fn a . loc $ Let (map toDef fs) body
90extracts :: [Pattern] -> LExpr t v -> Unique ([String], LExpr t v)
91extracts ps body = go [] (reverse ps) body
92 where go args [] body = return (args, body)
93 go args (p:ps) body = do (x,e) <- extract p body
94 go (x:args) ps e
96flatten :: [Pattern] -> LExpr t v -> Unique (IParser [Def t v])
97flatten patterns exp@(L t s _) =
98 let loc = L t s in
99 case patterns of
100 PVar f : args -> do
101 (as,e) <- extracts args exp
102 return . return $
103 if isOp (head f) then let [a,b] = as in [ OpDef f a b e ]
104 else [ FnDef f as e ]
106 [p] -> return `liftM` matchSingle p exp p
108 _ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++
109 ") cannot be used on the left-hand side of an assign statement."
111matchSingle :: Pattern -> LExpr t v -> Pattern -> Unique [Def t v]
112matchSingle pat exp@(L t s _) p =
113 let loc = L t s in
114 case p of
115 PData _ ps -> do
116 x <- guid
117 let v = '_' : show x
118 dss <- mapM (matchSingle pat . loc $ Var v) ps
119 return (FnDef v [] exp : concat dss)
121 PVar x ->
122 return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]
124 PAlias x p' -> do
125 subPat <- matchSingle p' (loc $ Var x) p'
126 return $ (FnDef x [] (loc $ Case exp [(pat, loc $ Var x)])):subPat
128 PRecord fs -> do
129 a <- (\x -> '_' : show x) `liftM` guid
130 let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
131 return (FnDef a [] exp : map toDef fs)
133 PAnything -> return []
134--}