CPL-0.2.0: src/Exp.hs

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

module Exp
    ( Id
    , Exp (..)
    , comp
    , expandFunct
    ) where

import qualified CDT
import qualified FE
import Type (GenType(..))
import Data.List (intercalate)

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

type Id = String

data Exp
    = Identity
    | Comp Exp Exp
    | Nat !CDT.Nat
    | Fact !CDT.CDT ![Exp]
    | Funct !CDT.CDT ![Exp]
    | Var !Id ![Exp]

instance Show Exp where
    show Identity = "I"
    show (Comp a b) = show a ++ "." ++ show b
    show (Nat nat)   = CDT.natName nat
    show (Fact fact args) = CDT.factName fact ++ showArgs args
    show (Funct funct args) = CDT.functName funct ++ showArgs args
    show (Var name args) = name ++ showArgs args

showArgs :: [Exp] -> String
showArgs [] = ""
showArgs args = "(" ++ intercalate "," (map show args) ++ ")"

{-# INLINE comp #-}
comp :: Exp -> Exp -> Exp
comp a Identity = a
comp Identity b = b
comp a b        = Comp a b

expandFunct :: CDT.CDT -> [Exp] -> Exp
expandFunct _   []   = Identity
expandFunct obj args = Fact obj (map g (CDT.nats obj))
    where g nat = FE.fold h expandFunct cod `comp`
                  (Nat nat `comp` FE.fold h expandFunct dom)
              where h 0 = Identity
                    h i = args !! (i-1)
                    dom:->cod = CDT.natDeclType nat