CPL-0.0.5: src/ExpParser.hs

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

module ExpParser
    ( Exp (..)
    , exp
    , def
    , evalExp
    ) where

import qualified CDT
import qualified Exp as E
import ParserUtils

import Prelude hiding (exp)
import Control.Monad
import Text.ParserCombinators.Parsec
import Data.Maybe
import qualified Data.Map as Map

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

data Exp
    = Comp Exp Exp
    | Ident String [Exp]
    deriving (Show, Read)

exp :: Parser Exp
exp =
    do xs <- sepBy1 pident (tok (char '.' `mplus` char '\x2218'))
       return (foldr1 Comp xs)
    where pident = 
              do s  <- ident
                 xs <- option [] $ between (char' '(') (char' ')')
                                 $ exp `sepBy` char' ','
                 spaces
                 return (Ident s xs)

def :: Parser (E.Id, [E.Id], Exp)
def = do
  spaces
  s <- ident
  ps <- option [] $ between (char' '(') (char' ')') $ ident `sepBy` char' ','
  spaces
  char' '='
  body <- exp
  spaces
  return (s, ps, body)

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

type CDTEnv = [CDT.CDT]

evalExp :: CDTEnv -> (Map.Map String Int) -> Exp -> Maybe E.Exp
evalExp cenv env = listToMaybe . f
    where f (Comp a b) =
              do a' <- f a
                 b' <- f b
                 return (E.Comp a' b')
          f (Ident "I" args) =
              do guard (length args == 0)
                 return E.Identity
          f (Ident s args)  =
              do let arity = length args
                 args' <- mapM f args
                 o <- cenv
                 msum [ do guard $ CDT.functName o  == s &&
                                   CDT.functArity o == arity
                           return (E.Funct o args')
                      , do guard $ CDT.factName o == s &&
                                   CDT.nNats o == arity
                           return (E.Fact o args')
                      , do guard $ arity == 0
                           n <- CDT.nats o
                           guard $ CDT.natName n == s
                           return (E.Nat n)
                      , do guard $ Just arity == Map.lookup s env
                           return (E.Var s args')
                      ]

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