{- |
Module      :  $Id: DataP.hs 14719 2011-03-16 13:29:01Z maeder $
Copyright   :  (c) DFKI GmbH
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Christian.Maeder@dfki.de
Stability   :  provisional
Portability :  portable

Adaptation and extension of a parser for data definitions given in
appendix of G. Huttons's paper - Monadic Parser Combinators.
-}

module DataP (Statement (..), Data (..), Type (..), Body (..),
               Name, Var, Class, Constructor,
               datadecl, newtypedecl)
where

import ParseLib2
import Data.Char


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

extContext :: Parser [()]
extContext = do
   symbol "forall"
   many1 variable
   char '.'
   junk
   constructorP
   many variable
   symbol "=>"
   return []

datadecl :: Parser Data
datadecl = do
    symbol "data"
    cons <- opt constraint
    x <- constructorP
    xs <- many variable
    symbol "="
    opt extContext
    b <- (infixdecl +++ conrecdecl) `sepby1` symbol "|"
    d <- opt deriveP
    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 (: []) 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 (: []) 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)
