CPL-0.0.8: src/CDTParser.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  CDTParser
-- Copyright   :  (c) Masahiro Sakai 2006,2009
-- License     :  BSD-style
-- 
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-----------------------------------------------------------------------------

module CDTParser
    ( FE
    , Type
    , CDTDecl
    , cdtDecl
    , evalCDTDecl
    ) where

import qualified FE
import qualified Type as T
import Type (GenType(..))
import CDT
import ParserUtils

import Text.ParserCombinators.Parsec
import Control.Monad
import Data.List

type FE   = FE.GenFE String
type Type = T.GenType String
data CDTDecl = CDTDecl !ObjectType String !Int String [(String, Type)]

cdtDecl :: Parser CDTDecl
cdtDecl = 
    do t <- mplus (string' "left"  >> return LeftObject)
                  (string' "right" >> return RightObject)
       string' "object"
       name <- ident
       params <- option [] $ between (char' '(') (char' ')')
                           $ sepBy ident (char' ',')
       spaces
       string' "with"
       fact_name <- ident
       let endObject  = string' "end" >> string' "object"
           normalDecl = do string' "is"
                           manyTill (try (nat_decl (name : params)))
                                    (try endObject)
           emptyDecl  = endObject >> return []
       nat_decls <- normalDecl <|> emptyDecl
       return $ CDTDecl t name (length params) fact_name nat_decls

nat_decl :: [String] -> Parser (String, Type)
nat_decl params = 
    do name <- ident
       char' ':'
       let f x = x `elemIndex` params
       a <- fe f
       string' "->" <|> string' "→"
       b <- fe f
       return (name, a :-> b)

fe :: (String -> Maybe Int) -> Parser FE
fe lookupVar = fe'
    where fe' = 
            do name <- ident
               params <- option [] $ between (char' '(') (char' ')')
                                   $ sepBy fe' (char' ',')
               spaces
               return $ case lookupVar name of
                        Just n  -> FE.Var n
                        Nothing -> FE.Ap name params

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

type CDTEnv = [CDT]

evalCDTDecl :: CDTEnv -> CDTDecl -> Either String CDT
evalCDTDecl cenv (CDTDecl lr name arity fact_name nat_decls) =
    do nat_decls' <- mapM (evalNatDecl cenv) nat_decls
       return $ mkCDT lr name arity fact_name nat_decls'

evalNatDecl :: CDTEnv -> (String, Type) -> Either String (String, T.Type)
evalNatDecl cenv (name, a :-> b) =
    do a' <- evalFE cenv a
       b' <- evalFE cenv b
       return (name, a' :-> b')

evalFE :: CDTEnv -> FE -> Either String FE.FE
evalFE _ (FE.Var n) = return (FE.Var n)
evalFE cenv (FE.Ap sym xs) =
    do ys <- mapM (evalFE cenv) xs
       case find (\cdt -> sym == CDT.functName cdt) cenv of
        Just f ->
            if CDT.functArity f == length xs
               then return (FE.Ap f ys)
               else Left "wrong number of arguments"
        Nothing ->
            Left $ "no such functor or variable: " ++ sym

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