{-# LANGUAGE PatternGuards,StandaloneDeriving,CPP #-}
module Tip.Id where
import Tip.Pretty
import Tip.Core
import Text.PrettyPrint (text)
import Name hiding (varName)
import OccName (occNameString)
-- import BasicTypes (TupleSort(..))
import PrelNames
import Tip.GHCUtils
import Var (Var,varName,idDetails,TyVar,tyVarName)
import IdInfo (IdDetails(..))
import TyCon (tyConName,TyCon)
import DataCon (dataConName,DataCon)
import Data.Char (toUpper)
import PrimOp
import TysWiredIn (trueDataCon,falseDataCon,boolTyCon)
idFromName :: Name -> Id
idFromName nm = GHCOrigin nm
idFromDataCon :: DataCon -> Id
idFromDataCon = idFromName . dataConName
idFromVar :: Var -> Id
idFromVar i = case idDetails i of
DataConWorkId dc -> idFromDataCon dc
DataConWrapId dc -> idFromDataCon dc
_ -> idFromName (varName i)
idFromTyVar :: TyVar -> Id
idFromTyVar = idFromName . tyVarName
idFromTyCon :: TyCon -> Id
idFromTyCon tc = idFromName (tyConName tc)
tryGetGHCName :: Id -> Maybe Name
tryGetGHCName (GHCOrigin nm) = Just nm
tryGetGHCName _ = Nothing
-- | A representation of identifiers that come from GHC.
--
-- The 'PrettyVar' instance is one way to print the names.
data Id
= GHCOrigin Name
| Id `LiftedFrom` Id
| Eta Int
| Discrim Id
| Project Id Int
| Error
deriving (Eq,Ord)
instance Show Id where
show (GHCOrigin n) = show (showOutputable n)
show (Eta n) = "eta" ++ show n
show (Discrim c) = "is-" ++ show c
show (Project c i) = show c ++ "_" ++ show i
show (i `LiftedFrom` j) = show i ++ " `LiftedFrom` " ++ show j
show Error = "error"
instance PrettyVar Id where
varStr = ppId
ppId :: Id -> String
ppId (GHCOrigin nm) = ppName nm
ppId (Eta n) = "eta" ++ show n
ppId (Discrim c) = "is-" ++ ppId c
ppId ((i `LiftedFrom` j) `LiftedFrom` k) = ppId (i `LiftedFrom` (j `LiftedFrom` k))
ppId (i `LiftedFrom` j)
| Just nm <- tryGetGHCName i, isSystemName nm = ppId j
| ppId i /= ppId j && "prop_" /= take 5 (ppId j) = ppId j ++ "_" ++ ppId i
| otherwise = ppId i
ppId (Project c i) = case (i,ppId c) of
(0,"Pair") -> "first"
(1,"Pair") -> "second"
(0,"cons") -> "head"
(1,"cons") -> "tail"
(0,"S") -> "p"
(0,"Succ") -> "pred"
_ -> ppId c ++ "_" ++ show i
ppId Error = "error"
ppName :: Name -> String
ppName nm
| k == listTyConKey = "list"
| k == nilDataConKey = "nil"
| k == consDataConKey = "cons"
| k == unitTyConKey = "Unit"
| k == genUnitDataConKey = "tt"
| isSystemName nm = "x"
| otherwise = case getOccString nm of
x | take 2 x == "ds" -> "x"
x | take 3 x == "ipv" -> "x"
"(,)" -> "Pair"
"(,,)" -> "Triple"
"+" -> "plus"
"-" -> "minus"
"/" -> "div"
"*" -> "mult"
"^" -> "pow"
"++" -> "append"
">>=" -> "bind"
"=<<" -> "dnib"
">=>" -> "dot_monadic"
"<=<" -> "monadic_dot"
"<*>" -> "ap"
"<$>" -> "fmap"
">>" -> "then"
"||" -> "or"
"&&" -> "and"
"." -> "dot"
"==" -> "equal"
"/=" -> "unequal"
">" -> "gt"
">=" -> "ge"
"<" -> "lt"
"<=" -> "le"
"$" -> "apply"
"!!" -> "index"
"\\\\" -> "difference"
s -> s
where
k = getUnique nm
primops :: [(PrimOp,Expr Id)]
primops =
[ (ghc_op,Lam [int 0] (Lam [int 1] (Builtin tip_id :@: [Lcl (int 0),Lcl (int 1)])))
| (ghc_op,tip_id) <-
[ (IntAddOp, IntAdd)
, (IntSubOp, IntSub)
, (IntMulOp, IntMul)
]
] ++
#if __GLASGOW_HASKELL__ <= 706
[ (ghc_op,Lam [int 0] (Lam [int 1] (Builtin tip_id :@: [Lcl (int 0),Lcl (int 1)])))
| (ghc_op,tip_id) <-
[ (IntEqOp, Equal)
, (IntNeOp, Distinct)
, (IntGtOp, IntGt)
, (IntGeOp, IntGe)
, (IntLtOp, IntLt)
, (IntLeOp, IntLe)
]
]
#else
[ (ghc_op,Lam [int 0] (Lam [int 1]
(makeIf (Builtin tip_id :@: [Lcl (int 0),Lcl (int 1)])
(literal (Int 1)) (literal (Int 0)))))
| (ghc_op,tip_id) <-
[ (IntEqOp, Equal)
, (IntNeOp, Distinct)
, (IntGtOp, IntGt)
, (IntGeOp, IntGe)
, (IntLtOp, IntLt)
, (IntLeOp, IntLe)
]
] ++
[ (TagToEnumOp,Lam [int 0] (Match (Lcl (int 0))
[ Case Default (bool False)
, Case (LitPat (Int 1)) (bool True)
]))
]
#endif
where
int i = Local (Eta i) intType