2014-01-03 11:33:56 +00:00
|
|
|
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
|
2013-06-14 02:15:40 +00:00
|
|
|
module Parse.Type where
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2012-06-10 04:21:16 +00:00
|
|
|
import Control.Applicative ((<$>),(<*>))
|
2014-01-03 11:33:56 +00:00
|
|
|
import Data.List (intercalate)
|
2012-06-10 04:21:16 +00:00
|
|
|
import Text.Parsec
|
|
|
|
|
2013-07-07 16:13:40 +00:00
|
|
|
import SourceSyntax.Type as T
|
2013-06-14 01:35:37 +00:00
|
|
|
import Parse.Helpers
|
2012-04-28 07:26:46 +00:00
|
|
|
|
2013-07-07 16:13:40 +00:00
|
|
|
tvar :: IParser T.Type
|
|
|
|
tvar = T.Var <$> lowVar <?> "type variable"
|
2013-07-04 09:36:08 +00:00
|
|
|
|
2013-07-07 16:13:40 +00:00
|
|
|
list :: IParser T.Type
|
|
|
|
list = listOf <$> braces expr
|
|
|
|
|
|
|
|
tuple :: IParser T.Type
|
|
|
|
tuple = do ts <- parens (commaSep expr)
|
|
|
|
return $ case ts of
|
|
|
|
[t] -> t
|
|
|
|
_ -> tupleOf ts
|
|
|
|
|
|
|
|
record :: IParser T.Type
|
2013-07-14 12:55:29 +00:00
|
|
|
record =
|
|
|
|
do char '{' ; whitespace
|
2013-10-20 02:14:34 +00:00
|
|
|
(ext,fs) <- extended <|> normal
|
2013-07-14 12:55:29 +00:00
|
|
|
dumbWhitespace ; char '}'
|
2013-07-26 16:20:57 +00:00
|
|
|
return (T.Record fs ext)
|
2013-06-07 17:16:38 +00:00
|
|
|
where
|
2013-10-20 02:14:34 +00:00
|
|
|
normal = (,) T.EmptyRecord <$> commaSep fields
|
|
|
|
|
|
|
|
-- extended record types require at least one field
|
|
|
|
extended = do
|
|
|
|
ext <- try (const <$> tvar <*> (whitespace >> string "|"))
|
|
|
|
whitespace
|
|
|
|
(,) ext <$> commaSep1 fields
|
|
|
|
|
2013-10-20 01:28:52 +00:00
|
|
|
fields = do
|
2013-10-20 02:14:34 +00:00
|
|
|
lbl <- rLabel
|
|
|
|
whitespace >> hasType >> whitespace
|
|
|
|
(,) lbl <$> expr
|
2013-07-07 16:13:40 +00:00
|
|
|
|
2014-01-03 11:33:56 +00:00
|
|
|
capTypeVar :: IParser String
|
2013-07-22 12:40:32 +00:00
|
|
|
capTypeVar = intercalate "." <$> dotSep1 capVar
|
2013-07-14 12:55:29 +00:00
|
|
|
|
2013-07-07 16:13:40 +00:00
|
|
|
constructor0 :: IParser T.Type
|
|
|
|
constructor0 =
|
2013-07-22 12:40:32 +00:00
|
|
|
do name <- capTypeVar
|
2013-07-07 16:13:40 +00:00
|
|
|
return (T.Data name [])
|
|
|
|
|
|
|
|
term :: IParser T.Type
|
|
|
|
term = list <|> tuple <|> record <|> tvar <|> constructor0
|
|
|
|
|
|
|
|
app :: IParser T.Type
|
|
|
|
app =
|
2013-07-22 12:40:32 +00:00
|
|
|
do name <- capTypeVar <|> try tupleCtor <?> "type constructor"
|
2013-07-07 16:13:40 +00:00
|
|
|
args <- spacePrefix term
|
|
|
|
return (T.Data name args)
|
2013-07-20 16:53:41 +00:00
|
|
|
where
|
|
|
|
tupleCtor = do
|
|
|
|
n <- length <$> parens (many (char ','))
|
|
|
|
return $ "_Tuple" ++ show (if n == 0 then 0 else n+1)
|
2013-07-07 16:13:40 +00:00
|
|
|
|
|
|
|
expr :: IParser T.Type
|
|
|
|
expr =
|
|
|
|
do t1 <- app <|> term
|
2013-09-06 19:22:01 +00:00
|
|
|
arr <- optionMaybe $ try (whitespace >> arrow)
|
2013-07-07 16:13:40 +00:00
|
|
|
case arr of
|
2013-09-06 19:22:01 +00:00
|
|
|
Just _ -> T.Lambda t1 <$> (whitespace >> expr)
|
2013-07-07 16:13:40 +00:00
|
|
|
Nothing -> return t1
|
|
|
|
|
|
|
|
constructor :: IParser (String, [T.Type])
|
2013-07-22 12:40:32 +00:00
|
|
|
constructor = (,) <$> (capTypeVar <?> "another type constructor")
|
2013-07-07 16:13:40 +00:00
|
|
|
<*> spacePrefix term
|