Adaptation and extension of a parser for data definitions given in
appendix of G. Huttons's paper - Monadic Parser Combinators.
Parser does not accept infix data constructors. This is a shortcoming that
needs to be fixed.
>module DataP (Statement(..),Data(..),Type(..),Body(..),
> Name,Var,Class,Constructor,
> datadecl,newtypedecl)
>where
>import ParseLib2
>import Data.Char
>import Data.List
>data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
>data Data = D { name :: Name, -- type name
> constraints :: [(Class,Var)],
> vars :: [Var], -- Parameters
> body :: [Body],
> derives :: [Class], -- derived classes
> statement :: Statement}
> | Directive
> | TypeName Name
> deriving (Eq,Show)
>data Body = Body { constructor :: Constructor,
> labels :: [Name],
> types :: [Type]} deriving (Eq,Show)
>type Name = String
>type Var = String
>type Class = String
>type Constructor = String
>----------------------------------------------------------------------------
>
>datadecl :: Parser Data
>datadecl = do
> symbol "data"
> con <- opt constraint
> x <- constructorP
> xs <- many variable
> symbol "="
> b <- (conrecdecl +++ infixdecl) `sepby1` symbol "|"
> d <- opt deriveP
> return $D x con xs b d DataStmt
>newtypedecl :: Parser Data
>newtypedecl = do
> symbol "newtype"
> con <- opt constraint
> x <- constructorP
> xs <- many variable
> symbol "="
> b <- conrecdecl
> d <- opt deriveP
> return $ D x con xs [b] d NewTypeStmt
>---------------------------------------------------------------------------
>constructorP = token $
> do {x <- upper;xs <- many alphanum;return (x:xs)} +++ do
> string "(:"
> y <- many1 $ sat (\x -> (not . isAlphaNum) x && (not . isSpace) x && (not . (== ')')) x )
> char ')'
> return ("(:" ++ y ++ ")")
>
>infixconstr = token $ do
> x <- char ':'
> y <- many1 $ sat (\x -> (not . isAlphaNum) x && (not . isSpace) x)
> return (x:y)
>
>variable = identifier [ "data","deriving","newtype", "type",
> "instance", "class", "module", "import",
> "infixl", "infix","infixr", "default"]
>condecl = do
> x <- constructorP
> ts <- many type2
> return $ Body x [] ts
>conrecdecl = do
> x <- constructorP
> (ls,ts) <- record +++ fmap (\a -> ([],a)) (many type2)
> return $ Body x ls ts
>-- haven't worked infixes into the program yet, as they cause problems
>-- throughout
>infixdecl = do
> t1 <- type2
> x <- infixconstr
> ts <- many1 type2
> return $ Body ("(" ++ x ++ ")") [] (t1:ts)
>record = do
> symbol "{"
> (ls,ts) <- fmap unzip $ rectype `sepby1` symbol ","
> symbol "}"
> return (ls,ts)
>constraint = do{x <- constrs; symbol "=>"; return x}
> where
> constrs = fmap (\x -> [x]) one +++
> bracket (symbol "(") (one `sepby` symbol ",") (symbol ")")
> one = do{c <- constructorP; v <- variable; return (c,v)}
>deriveP = do{symbol "deriving"; one +++ more}
> where
> one = fmap (\x -> [x]) constructorP -- well, it has the same form
> more = bracket (symbol "(")
> (((type0 >>= return . show)) `sepby` symbol ",")
> (symbol ")")
>---------------------------------------------------------------------------
>data Type = Arrow Type Type -- fn
> | LApply Type [Type] -- proper application
> | Var String -- variable
> | Con String -- constructor
> | Tuple [Type] -- tuple
> | List Type -- list
> deriving (Eq)
>instance Show Type where
> show (Var s) = s
> show (Con s) = s
> show (Tuple ts) = "(" ++ concat (intersperse "," (map show ts)) ++ ")"
> show (List t) = "[" ++ show t ++ "]"
> show (Arrow a b) = show a ++ " -> " ++ show b
> show (LApply t ts) = concat $ intersperse " " (map show (t:ts))
>type0 :: Parser Type
>type0 = type1 `chainr1` fmap (const Arrow) (symbol "->")
>--type1 = type2 `chainl1` (return Apply)
>type1 = (do c <- con
> as <- many1 type2
> return (LApply c as)) +++
> type2
>type2 = (char '!') +++ return '!' >> var +++ con +++ list +++ tuple
>var = fmap Var variable
>con = fmap Con constructorP
>list = fmap List $ bracket (symbol "[")
> type0
> (symbol "]")
>tuple = fmap f $ bracket (symbol "(")
> (type0 `sepby` symbol ",")
> (symbol ")")
> where f [t] = t
> f ts = Tuple ts
>--record entry
>rectype :: Parser (String,Type)
>rectype = do
> s <- variable
> symbol "::"
> t <- type0
> return (s,t)