823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny{-

823a5b3f4375f12b6edae4dd5169ee01771baebeJan ZelenyAdaptation and extension of a parser for data definitions given in

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenyappendix of G. Huttons's paper - Monadic Parser Combinators.

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny-}

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenymodule DataP (Statement(..),Data(..),Type(..),Body(..),

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny Name,Var,Class,Constructor,

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny datadecl,newtypedecl)

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenywhere

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenyimport ParseLib2

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenyimport Data.Char

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenydata Statement = DataStmt | NewTypeStmt deriving (Eq,Show)

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenydata Data = D { name :: Name, -- type name

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny constraints :: [(Class,Var)],

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny vars :: [Var], -- Parameters

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny body :: [Body],

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny derives :: [Class], -- derived classes

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny statement :: Statement}

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny | Directive

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny | TypeName Name

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny deriving (Eq,Show)

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenydata Body = Body { constructor :: Constructor,

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny labels :: [Name],

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny types :: [Type]} deriving (Eq,Show)

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenytype Name = String

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenytype Var = String

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenytype Class = String

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenytype Constructor = String

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny----------------------------------------------------------------------------

1a3e6221b38a7cae27d7e84a30bb8ea3c3900a47Jan Zeleny

1a3e6221b38a7cae27d7e84a30bb8ea3c3900a47Jan ZelenyextContext :: Parser [()]

1a3e6221b38a7cae27d7e84a30bb8ea3c3900a47Jan ZelenyextContext = do

1a3e6221b38a7cae27d7e84a30bb8ea3c3900a47Jan Zeleny symbol "forall"

1a3e6221b38a7cae27d7e84a30bb8ea3c3900a47Jan Zeleny many1 variable

1a3e6221b38a7cae27d7e84a30bb8ea3c3900a47Jan Zeleny char '.'

1a3e6221b38a7cae27d7e84a30bb8ea3c3900a47Jan Zeleny junk

1a3e6221b38a7cae27d7e84a30bb8ea3c3900a47Jan Zeleny constructorP

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny many variable

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny symbol "=>"

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny return []

2ce00e0d3896bb42db169d1e79553a81ca837a22Simo Sorce

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenydatadecl :: Parser Data

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zelenydatadecl = do

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny symbol "data"

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny cons <- opt constraint

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny x <- constructorP

1a3e6221b38a7cae27d7e84a30bb8ea3c3900a47Jan Zeleny xs <- many variable

1a3e6221b38a7cae27d7e84a30bb8ea3c3900a47Jan Zeleny symbol "="

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny opt extContext

b42bb7d9dbf9a4c44a03e7bf1bab471a8a85e858Michal Zidek b <- (infixdecl +++ conrecdecl) `sepby1` symbol "|"

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny d <- opt deriveP

823a5b3f4375f12b6edae4dd5169ee01771baebeJan Zeleny return $ D x cons xs b d DataStmt

newtypedecl :: Parser Data

newtypedecl = do

symbol "newtype"

cons <- opt constraint

x <- constructorP

xs <- many variable

symbol "="

b <- conrecdecl

d <- opt deriveP

return $ D x cons xs [b] d NewTypeStmt

---------------------------------------------------------------------------

isSign :: Char -> Bool

isSign x = not (isAlpha x || isSpace x || elem x "\"|[](){}")

constructorP :: Parser String

constructorP = token $

do {x <- upper;xs <- many alphanum;return (x:xs)} +++ do

char '('

junk

char ':'

y <- many1 $ sat isSign

junk

char ')'

return ("(:" ++ y ++ ")")

infixconstr :: Parser String

infixconstr = token $ do

x <- char ':'

y <- many1 $ sat isSign

return (x:y)

variable :: Parser String

variable = identifier [ "data","deriving","newtype", "type", "forall",

"instance", "class", "module", "import",

"infixl", "infix","infixr", "default"]

conrecdecl :: Parser Body

conrecdecl = do

x <- constructorP

(ls,ts) <- record +++ fmap (\a -> ([],a)) (many type2)

return $ Body x ls ts

infixdecl :: Parser Body

infixdecl = do

t1 <- type2

x <- infixconstr

ts <- many1 type2

return $ Body ("(" ++ x ++ ")") [] (t1:ts)

record :: Parser ([String], [Type])

record = do

symbol "{"

(ls,ts) <- fmap unzip $ rectype `sepby1` symbol ","

symbol "}"

return (ls,ts)

constraint :: Parser [(String, String)]

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 :: Parser [String]

deriveP = do{symbol "deriving"; one +++ more}

where

one = fmap (\x -> [x]) constructorP -- well, it has the same form

more = bracket (symbol "(")

(constructorP `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,Show)

type0 :: Parser Type

type0 = type1 `chainr1` fmap (const Arrow) (symbol "->")

type1 :: Parser Type

type1 = (do c <- con

as <- many1 type2

return (LApply c as)) +++

type2

type2 :: Parser Type

type2 = (char '!') +++ return '!' >> var +++ con +++ list +++ tuple

var :: Parser Type

var = fmap Var variable

con :: Parser Type

con = fmap Con constructorP

list :: Parser Type

list = fmap List $ bracket (symbol "[")

type0

(symbol "]")

tuple :: Parser Type

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 "::"

opt $ symbol "!"

t <- type0

return (s,t)