-----------------------------------------------------------------------------
-- |
-- Module      :  Pointfree
-- Copyright   :  (c) Jose Proenca 2005
-- License     :  GPL
--
-- Maintainer  :  jproenca@di.uminho.pt
-- Stability   :  experimental
-- Portability :  portable
--
-- A syntax of a general pointfree language.
--
-----------------------------------------------------------------------------

module Pointfree (
  -- * Data Type
  {-| Represents a pointfree language where:
        
        (1) products and sums are treated

        (2) base types are obtained and decomposed by the use of the /IN/ and
            /OUT/ constructors

        (3) recursion can be expressed by the point-fix function or by a paramorphism

        (4) free variables are called macros and represent known pointfree expressions
  -} 
  PFTerm (..),
  
  -- * Conversion of a "PFTerm" to an haskell expression
  pf2Exp

) where

import RefacUtils


data PFTerm = BANG             -- ^Constant function that returns Unit
          | ID                 -- ^Identity
          | APP                -- ^Apply
          | Curry PFTerm       -- ^Curry
          | PFTerm :.: PFTerm  -- ^Composition
          | PFTerm :\/: PFTerm -- ^Either
          | PFTerm :/\: PFTerm -- ^Split
          | FST                -- ^Point-free first
          | SND                -- ^Point-free second
          | INL                -- ^Point-free left injection
          | INR                -- ^Point-free right injection
          | IN HsExpP          -- ^Injection on a specified type
          | OUT HsExpP         -- ^Gets the functor
          | PARA HsExpP PFTerm -- ^Paramorphism
          | FIX                -- ^Fixed point function
          | Macro String       -- ^Macros of frequently used pointfree terms
            deriving Show
 

-- Implementation of a pointfree term on a HsExp
{- | Applies a tranformation from a 'PFTerm' to an expression of programatica's
     abstract tree. Note that the type information inside the /IN/, /OUT/ and /PARA/
     terms is represented as a programatica's expression @L::type@, where the @type@
     is the real type information.
-}
pf2Exp :: PFTerm -> HsExpI PNT

pf2Exp BANG = nameToExp "bang"
pf2Exp ID = prelVar "id"
pf2Exp APP = nameToExp "app"

pf2Exp (Curry t1)   = Exp $ HsApp (nameToExp "curry") (mbParen$ pf2Exp t1)
pf2Exp (t1 :.: t2)  = Exp (HsInfixApp  (mbParen$ pf2Exp t1)
                           (prelOp ".") (mbParen$ pf2Exp t2))
pf2Exp (t1 :\/: t2)  = Exp (HsInfixApp  (mbParen$ pf2Exp t1)
                           (nameToOp "\\/") (mbParen$ pf2Exp t2))
pf2Exp (t1 :/\: t2)  = Exp (HsInfixApp  (mbParen$ pf2Exp t1)
                           (nameToOp "/\\") (mbParen$ pf2Exp t2))

pf2Exp FST          = nameToExp "fst"
pf2Exp SND          = nameToExp "snd"
pf2Exp INL          = prelCon "Left"
pf2Exp INR          = prelCon "Right"


pf2Exp (IN typ)     = -- inN (_L::str)
    Exp (HsApp (nameToExp "inN") typ)--(Exp $ HsParen $ typedExp "_L" str))
pf2Exp (OUT typ)    = -- ouT (_L::str)
    Exp (HsApp (nameToExp "ouT") typ)--(Exp $ HsParen $ typedExp "_L" str))

pf2Exp (PARA typ t) = -- para (_L::str) t
    Exp (HsApp (Exp $ HsApp (nameToExp "para") typ)--(Exp $ HsParen $ typedExp "_L" str))
      (mbParen$ pf2Exp t))
pf2Exp FIX       = nameToExp "fix"

pf2Exp (Macro str)  = nameToExp str
 


---------------------------
--- auxiliary functions ---
---------------------------

-- nameToExp is imported from RefacUtils.hs
-- nameToExp str = Exp (HsId (HsVar (PNT (PN (UnQual str) (S loc0)) Value (N (Just loc0)))))

prelVar str = Exp (HsId (HsVar (PNT (PN (UnQual str) (G (PlainModule "Prelude") str (N (Just loc0)))) Value (N (Just loc0)))))

conToExp str = Exp (HsId (HsCon (PNT (PN (UnQual str) (S loc0)) Value (N (Just loc0)))))

prelCon str = Exp (HsId (HsCon (PNT (PN (UnQual str) (G (PlainModule "Prelude") str (N (Just loc0)))) Value (N (Just loc0)))))

-- | places parentisis in an expression only if it is necessary
--mbParen :: EI -> HsExp
mbParen e@(Exp (HsApp _ _)) = Exp $ HsParen e
mbParen e@(Exp (HsInfixApp _ _ _)) = Exp $ HsParen e
mbParen e@(Exp (HsCase _ _)) = Exp $ HsParen e
mbParen e@(Exp (HsLambda _ _)) = Exp $ HsParen e
mbParen x = x

prelOp str = (HsVar (PNT (PN (UnQual str) (G (PlainModule "Prelude") str (N (Just loc0)))) Value (N (Just loc0))))
nameToOp str = (HsVar (PNT (PN (UnQual str) (S loc0)) Value (N (Just loc0))))


typedExp strVar strType = Exp (HsExpTypeSig loc0 (nameToExp strVar) [] (Typ $ HsTyVar (PNT (PN (UnQual strType) (S loc0)) (Type (TypeInfo {defType = Nothing, constructors = [], fields = []})) (N (Just loc0)))))