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 ps m es is ds) = do
es' <- qExportSpec es
ds' <- mapM qDecl ds
return (Module 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 x) = Export <$> qIdent x
qExport (ExportTypeWith t cs) = flip ExportTypeWith cs <$> qConstr t
qExport (ExportTypeAll t) = ExportTypeAll <$> 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 vs cx n tys) =
flip (ConstrDecl p vs) n <$> qContext cx <*> mapM qTypeExpr tys
qConstrDecl (ConOpDecl p vs cx ty1 op ty2) =
ConOpDecl p vs <$> qContext cx <*> qTypeExpr ty1 <*> pure op <*> qTypeExpr ty2
qConstrDecl (RecordDecl p vs cx c fs) =
flip (RecordDecl p vs) c <$> qContext cx <*> 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 cls ty) = Constraint <$> qClass cls <*> qTypeExpr ty
qContext :: Qual Context
qContext = mapM qConstraint
qTypeExpr :: Qual TypeExpr
qTypeExpr (ConstructorType c) = ConstructorType <$> qConstr c
qTypeExpr (ApplyType ty1 ty2) = ApplyType <$> qTypeExpr ty1
<*> qTypeExpr ty2
qTypeExpr v@(VariableType _) = return v
qTypeExpr (TupleType tys) = TupleType <$> mapM qTypeExpr tys
qTypeExpr (ListType ty) = ListType <$> qTypeExpr ty
qTypeExpr (ArrowType ty1 ty2) = ArrowType <$> qTypeExpr ty1
<*> qTypeExpr ty2
qTypeExpr (ParenType ty) = ParenType <$> qTypeExpr ty
qTypeExpr (ForallType vs ty) = ForallType vs <$> qTypeExpr ty
qQualTypeExpr :: Qual QualTypeExpr
qQualTypeExpr (QualTypeExpr cx ty) = QualTypeExpr <$> 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 f ts) = FunLhs f <$> mapM qPattern ts
qLhs (OpLhs t1 op t2) = flip OpLhs op <$> qPattern t1 <*> qPattern t2
qLhs (ApLhs lhs ts) = ApLhs <$> 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 a c ts) = ConstructorPattern a
<$> qIdent c <*> mapM qPattern ts
qPattern (InfixPattern a t1 op t2) = InfixPattern a <$> qPattern t1
<*> qIdent op
<*> qPattern t2
qPattern (ParenPattern t) = ParenPattern <$> qPattern t
qPattern (RecordPattern a c fs) = RecordPattern a <$> qIdent c
<*> mapM (qField qPattern) fs
qPattern (TuplePattern ts) = TuplePattern <$> mapM qPattern ts
qPattern (ListPattern a ts) = ListPattern a <$> mapM qPattern ts
qPattern (AsPattern v t) = AsPattern v <$> qPattern t
qPattern (LazyPattern t) = LazyPattern <$> qPattern t
qPattern (FunctionPattern a f ts) = FunctionPattern a <$> qIdent f
<*> mapM qPattern ts
qPattern (InfixFuncPattern a t1 op t2) = InfixFuncPattern a <$> qPattern t1
<*> qIdent op
<*> qPattern t2
qRhs :: Qual (Rhs a)
qRhs (SimpleRhs p e ds) = SimpleRhs p <$> qExpr e <*> mapM qDecl ds
qRhs (GuardedRhs es ds) = GuardedRhs <$> 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 a v) = Variable a <$> qIdent v
qExpr (Constructor a c) = Constructor a <$> qIdent c
qExpr (Paren e) = Paren <$> qExpr e
qExpr (Typed e qty) = Typed <$> qExpr e
<*> qQualTypeExpr qty
qExpr (Record a c fs) =
Record a <$> qIdent c <*> mapM (qField qExpr) fs
qExpr (RecordUpdate e fs) = RecordUpdate <$> qExpr e
<*> mapM (qField qExpr) fs
qExpr (Tuple es) = Tuple <$> mapM qExpr es
qExpr (List a es) = List a <$> mapM qExpr es
qExpr (ListCompr e qs) = ListCompr <$> qExpr e <*> mapM qStmt qs
qExpr (EnumFrom e) = EnumFrom <$> qExpr e
qExpr (EnumFromThen e1 e2) = EnumFromThen <$> qExpr e1 <*> qExpr e2
qExpr (EnumFromTo e1 e2) = EnumFromTo <$> qExpr e1 <*> qExpr e2
qExpr (EnumFromThenTo e1 e2 e3) = EnumFromThenTo <$> qExpr e1 <*> qExpr e2
<*> qExpr e3
qExpr (UnaryMinus e) = UnaryMinus <$> qExpr e
qExpr (Apply e1 e2) = Apply <$> qExpr e1 <*> qExpr e2
qExpr (InfixApply e1 op e2) = InfixApply <$> qExpr e1 <*> qInfixOp op
<*> qExpr e2
qExpr (LeftSection e op) = LeftSection <$> qExpr e <*> qInfixOp op
qExpr (RightSection op e) = RightSection <$> qInfixOp op <*> qExpr e
qExpr (Lambda ts e) = Lambda <$> mapM qPattern ts <*> qExpr e
qExpr (Let ds e) = Let <$> mapM qDecl ds <*> qExpr e
qExpr (Do sts e) = Do <$> mapM qStmt sts <*> qExpr e
qExpr (IfThenElse e1 e2 e3) = IfThenElse <$> qExpr e1 <*> qExpr e2
<*> qExpr e3
qExpr (Case ct e as) = Case ct <$> qExpr e <*> mapM qAlt as
qStmt :: Qual (Statement a)
qStmt (StmtExpr e) = StmtExpr <$> qExpr e
qStmt (StmtBind t e) = StmtBind <$> qPattern t <*> qExpr e
qStmt (StmtDecl ds) = StmtDecl <$> 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