{-# LANGUAGE CPP #-}
module Transformations.Qual (qual) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>), pure)
#endif
import qualified Control.Monad.Reader as R (Reader, asks, runReader)
import Data.Traversable
import Prelude hiding (mapM)
import Curry.Base.Ident
import Curry.Syntax
import Base.TopEnv (origName)
import Env.TypeConstructor (TCEnv , qualLookupTypeInfo)
import Env.Value (ValueEnv, qualLookupValue)
data QualEnv = QualEnv
{ moduleIdent :: ModuleIdent
, tyConsEnv :: TCEnv
, valueEnv :: ValueEnv
}
type Qual a = a -> R.Reader QualEnv a
qual :: ModuleIdent -> TCEnv -> ValueEnv -> Module a -> Module a
qual m tcEnv tyEnv mdl = R.runReader (qModule mdl) (QualEnv m tcEnv tyEnv)
qModule :: Qual (Module a)
qModule (Module spi ps m es is ds) = do
es' <- qExportSpec es
ds' <- mapM qDecl ds
return (Module spi ps m es' is ds')
qExportSpec :: Qual (Maybe ExportSpec)
qExportSpec Nothing = return Nothing
qExportSpec (Just (Exporting p es)) = (Just . Exporting p) <$> mapM qExport es
qExport :: Qual Export
qExport (Export spi x) = Export spi <$> qIdent x
qExport (ExportTypeWith spi t cs) = flip (ExportTypeWith spi) cs <$> qConstr t
qExport (ExportTypeAll spi t) = ExportTypeAll spi <$> qConstr t
qExport m@(ExportModule _ _) = return m
qDecl :: Qual (Decl a)
qDecl i@(InfixDecl _ _ _ _) = return i
qDecl (DataDecl p n vs cs clss) = DataDecl p n vs <$>
mapM qConstrDecl cs <*> mapM qClass clss
qDecl e@(ExternalDataDecl _ _ _) = return e
qDecl (NewtypeDecl p n vs nc clss) = NewtypeDecl p n vs <$>
qNewConstrDecl nc <*> mapM qClass clss
qDecl (TypeDecl p n vs ty) = TypeDecl p n vs <$> qTypeExpr ty
qDecl (TypeSig p fs qty) = TypeSig p fs <$> qQualTypeExpr qty
qDecl (FunctionDecl a p f eqs) = FunctionDecl a p f <$> mapM qEquation eqs
qDecl e@(ExternalDecl _ _) = return e
qDecl (PatternDecl p t rhs) = PatternDecl p <$> qPattern t <*> qRhs rhs
qDecl vs@(FreeDecl _ _) = return vs
qDecl (DefaultDecl p tys) = DefaultDecl p <$> mapM qTypeExpr tys
qDecl (ClassDecl p cx cls tv ds) = ClassDecl p <$>
qContext cx <*> pure cls <*> pure tv <*> mapM qDecl ds
qDecl (InstanceDecl p cx qcls ty ds) = InstanceDecl p <$>
qContext cx <*> qClass qcls <*> qTypeExpr ty <*> mapM qDecl ds
qConstrDecl :: Qual ConstrDecl
qConstrDecl (ConstrDecl p n tys) =
ConstrDecl p n <$> mapM qTypeExpr tys
qConstrDecl (ConOpDecl p ty1 op ty2) =
ConOpDecl p <$> qTypeExpr ty1 <*> pure op <*> qTypeExpr ty2
qConstrDecl (RecordDecl p c fs) =
RecordDecl p c <$> mapM qFieldDecl fs
qNewConstrDecl :: Qual NewConstrDecl
qNewConstrDecl (NewConstrDecl p n ty)
= NewConstrDecl p n <$> qTypeExpr ty
qNewConstrDecl (NewRecordDecl p n (f, ty))
= (\ty' -> NewRecordDecl p n (f, ty')) <$> qTypeExpr ty
qFieldDecl :: Qual FieldDecl
qFieldDecl (FieldDecl p fs ty) = FieldDecl p fs <$> qTypeExpr ty
qConstraint :: Qual Constraint
qConstraint (Constraint spi cls ty) =
Constraint spi <$> qClass cls <*> qTypeExpr ty
qContext :: Qual Context
qContext = mapM qConstraint
qTypeExpr :: Qual TypeExpr
qTypeExpr (ConstructorType spi c) = ConstructorType spi <$> qConstr c
qTypeExpr (ApplyType spi ty1 ty2) = ApplyType spi <$> qTypeExpr ty1
<*> qTypeExpr ty2
qTypeExpr v@(VariableType _ _) = return v
qTypeExpr (TupleType spi tys) = TupleType spi <$> mapM qTypeExpr tys
qTypeExpr (ListType spi ty) = ListType spi <$> qTypeExpr ty
qTypeExpr (ArrowType spi ty1 ty2) = ArrowType spi <$> qTypeExpr ty1
<*> qTypeExpr ty2
qTypeExpr (ParenType spi ty) = ParenType spi <$> qTypeExpr ty
qTypeExpr (ForallType spi vs ty) = ForallType spi vs <$> qTypeExpr ty
qQualTypeExpr :: Qual QualTypeExpr
qQualTypeExpr (QualTypeExpr spi cx ty) = QualTypeExpr spi <$> qContext cx
<*> qTypeExpr ty
qEquation :: Qual (Equation a)
qEquation (Equation p lhs rhs) = Equation p <$> qLhs lhs <*> qRhs rhs
qLhs :: Qual (Lhs a)
qLhs (FunLhs sp f ts) = FunLhs sp f <$> mapM qPattern ts
qLhs (OpLhs sp t1 op t2) = flip (OpLhs sp) op <$> qPattern t1 <*> qPattern t2
qLhs (ApLhs sp lhs ts) = ApLhs sp <$> qLhs lhs <*> mapM qPattern ts
qPattern :: Qual (Pattern a)
qPattern l@(LiteralPattern _ _ _) = return l
qPattern n@(NegativePattern _ _ _) = return n
qPattern v@(VariablePattern _ _ _) = return v
qPattern (ConstructorPattern spi a c ts) =
ConstructorPattern spi a <$> qIdent c <*> mapM qPattern ts
qPattern (InfixPattern spi a t1 op t2) =
InfixPattern spi a <$> qPattern t1 <*> qIdent op <*> qPattern t2
qPattern (ParenPattern spi t) = ParenPattern spi <$> qPattern t
qPattern (RecordPattern spi a c fs) = RecordPattern spi a <$> qIdent c
<*> mapM (qField qPattern) fs
qPattern (TuplePattern spi ts) =
TuplePattern spi <$> mapM qPattern ts
qPattern (ListPattern spi a ts) =
ListPattern spi a <$> mapM qPattern ts
qPattern (AsPattern spi v t) = AsPattern spi v <$> qPattern t
qPattern (LazyPattern spi t) = LazyPattern spi <$> qPattern t
qPattern (FunctionPattern spi a f ts) =
FunctionPattern spi a <$> qIdent f <*> mapM qPattern ts
qPattern (InfixFuncPattern spi a t1 op t2) =
InfixFuncPattern spi a <$> qPattern t1 <*> qIdent op <*> qPattern t2
qRhs :: Qual (Rhs a)
qRhs (SimpleRhs spi e ds) =
SimpleRhs spi <$> qExpr e <*> mapM qDecl ds
qRhs (GuardedRhs spi es ds) =
GuardedRhs spi <$> mapM qCondExpr es <*> mapM qDecl ds
qCondExpr :: Qual (CondExpr a)
qCondExpr (CondExpr p g e) = CondExpr p <$> qExpr g <*> qExpr e
qExpr :: Qual (Expression a)
qExpr l@(Literal _ _ _) = return l
qExpr (Variable spi a v) = Variable spi a <$> qIdent v
qExpr (Constructor spi a c) = Constructor spi a <$> qIdent c
qExpr (Paren spi e) = Paren spi <$> qExpr e
qExpr (Typed spi e qty) = Typed spi <$> qExpr e
<*> qQualTypeExpr qty
qExpr (Record spi a c fs) =
Record spi a <$> qIdent c <*> mapM (qField qExpr) fs
qExpr (RecordUpdate spi e fs) =
RecordUpdate spi <$> qExpr e <*> mapM (qField qExpr) fs
qExpr (Tuple spi es) = Tuple spi <$> mapM qExpr es
qExpr (List spi a es) = List spi a <$> mapM qExpr es
qExpr (ListCompr spi e qs) = ListCompr spi <$> qExpr e
<*> mapM qStmt qs
qExpr (EnumFrom spi e) = EnumFrom spi <$> qExpr e
qExpr (EnumFromThen spi e1 e2) = EnumFromThen spi <$> qExpr e1
<*> qExpr e2
qExpr (EnumFromTo spi e1 e2) = EnumFromTo spi <$> qExpr e1
<*> qExpr e2
qExpr (EnumFromThenTo spi e1 e2 e3) = EnumFromThenTo spi <$> qExpr e1
<*> qExpr e2
<*> qExpr e3
qExpr (UnaryMinus spi e) = UnaryMinus spi <$> qExpr e
qExpr (Apply spi e1 e2) = Apply spi <$> qExpr e1
<*> qExpr e2
qExpr (InfixApply spi e1 op e2) = InfixApply spi <$> qExpr e1
<*> qInfixOp op
<*> qExpr e2
qExpr (LeftSection spi e op) = LeftSection spi <$> qExpr e
<*> qInfixOp op
qExpr (RightSection spi op e) = RightSection spi <$> qInfixOp op
<*> qExpr e
qExpr (Lambda spi ts e) = Lambda spi <$> mapM qPattern ts
<*> qExpr e
qExpr (Let spi ds e) = Let spi <$> mapM qDecl ds <*> qExpr e
qExpr (Do spi sts e) = Do spi <$> mapM qStmt sts <*> qExpr e
qExpr (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> qExpr e1 <*> qExpr e2
<*> qExpr e3
qExpr (Case spi ct e as) = Case spi ct <$> qExpr e <*> mapM qAlt as
qStmt :: Qual (Statement a)
qStmt (StmtExpr spi e) = StmtExpr spi <$> qExpr e
qStmt (StmtBind spi t e) = StmtBind spi <$> qPattern t <*> qExpr e
qStmt (StmtDecl spi ds) = StmtDecl spi <$> mapM qDecl ds
qAlt :: Qual (Alt a)
qAlt (Alt p t rhs) = Alt p <$> qPattern t <*> qRhs rhs
qField :: Qual a -> Qual (Field a)
qField q (Field p l x) = Field p <$> qIdent l <*> q x
qInfixOp :: Qual (InfixOp a)
qInfixOp (InfixOp a op) = InfixOp a <$> qIdent op
qInfixOp (InfixConstr a op) = InfixConstr a <$> qIdent op
qIdent :: Qual QualIdent
qIdent x | isQualified x = x'
| hasGlobalScope (unqualify x) = x'
| otherwise = return x
where
x' = do
m <- R.asks moduleIdent
tyEnv <- R.asks valueEnv
return $ case qualLookupValue x tyEnv of
[y] -> origName y
_ -> case qualLookupValue qmx tyEnv of
[y] -> origName y
_ -> qmx
where qmx = qualQualify m x
qConstr :: Qual QualIdent
qConstr x = do
m <- R.asks moduleIdent
tcEnv <- R.asks tyConsEnv
return $ case qualLookupTypeInfo x tcEnv of
[y] -> origName y
_ -> case qualLookupTypeInfo qmx tcEnv of
[y] -> origName y
_ -> qmx
where qmx = qualQualify m x
qClass :: Qual QualIdent
qClass = qConstr