module Generators.GenAbstractCurry (genAbstractCurry) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>), pure)
#endif
import Control.Monad.Extra
import qualified Control.Monad.State as S (State, evalState, get, gets
, modify, put, when)
import qualified Data.Map as Map (Map, empty, fromList, lookup
, union)
import qualified Data.Maybe as Maybe (fromJust, fromMaybe, listToMaybe)
import qualified Data.Set as Set (Set, empty, insert, member)
import qualified Data.Traversable as T (forM)
import Curry.AbstractCurry
import Curry.Base.Ident
import Curry.Syntax
import Base.CurryTypes (fromPredType, toType, toPredType)
import Base.Expr (bv)
import Base.Messages (internalError)
import Base.NestEnv
import Base.Types (arrowArity, PredType, unpredType, TypeScheme (..))
import Base.TypeSubst
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
import Env.OpPrec (mkPrec)
import CompilerEnv
type GAC a = S.State AbstractEnv a
genAbstractCurry :: Bool -> CompilerEnv -> Module PredType -> CurryProg
genAbstractCurry uacy env mdl
= S.evalState (trModule mdl) (abstractEnv uacy env mdl)
trModule :: Module PredType -> GAC CurryProg
trModule (Module _ mid _ is ds) = do
CurryProg mid' is' <$> dflt' <*> cds' <*> ids' <*> ts' <*> fs' <*> os'
where
mid' = moduleName mid
is' = map cvImportDecl is
dflt' = Maybe.listToMaybe <$> concatMapM (withLocalEnv . trDefaultDecl) ds
cds' = concatMapM (withLocalEnv . trClassDecl) ds
ids' = concatMapM (withLocalEnv . trInstanceDecl) ds
ts' = concatMapM (withLocalEnv . trTypeDecl) ds
fs' = concatMapM (withLocalEnv . trFuncDecl True) ds
os' = concatMapM (withLocalEnv . trInfixDecl) ds
cvImportDecl :: ImportDecl -> String
cvImportDecl (ImportDecl _ mid _ _ _) = moduleName mid
trDefaultDecl :: Decl a -> GAC [CDefaultDecl]
trDefaultDecl (DefaultDecl _ tys) = (\tys' -> [CDefaultDecl tys'])
<$> mapM trTypeExpr tys
trDefaultDecl _ = return []
trClassDecl :: Decl PredType -> GAC [CClassDecl]
trClassDecl (ClassDecl _ cx cls tv ds) = do
(\cls' v' cx' tv' ds' -> [CClass cls' v' cx' tv' ds'])
<$> trGlobalIdent cls <*> getTypeVisibility cls <*> trContext cx
<*> getTVarIndex tv <*> concatMapM (trClassMethodDecl sigs fs) ds
where fs = [f | FunctionDecl _ _ f _ <- ds]
sigs = signatures ds
trClassDecl _ = return []
trClassMethodDecl :: [(Ident, QualTypeExpr)] -> [Ident] -> Decl PredType
-> GAC [CFuncDecl]
trClassMethodDecl sigs fs (TypeSig p [f] _) | f `notElem` fs =
trClassMethodDecl sigs fs $ FunctionDecl p undefined f []
trClassMethodDecl sigs fs (TypeSig p (f:f':fs') qty) = do
liftM2 (++) (trClassMethodDecl sigs fs $ TypeSig p [f] qty)
(trClassMethodDecl sigs fs $ TypeSig p (f':fs') qty)
trClassMethodDecl sigs _ (FunctionDecl _ _ f eqs) =
(\f' a v ty rs -> [CFunc f' a v ty rs]) <$> trGlobalIdent f
<*> pure (maybe 0 eqnArity $ Maybe.listToMaybe eqs)
<*> getVisibility (unRenameIdent f)
<*> trQualTypeExpr (Maybe.fromJust $ lookup f sigs) <*> mapM trEquation eqs
trClassMethodDecl _ _ _ = return []
trInstanceDecl :: Decl PredType -> GAC [CInstanceDecl]
trInstanceDecl (InstanceDecl _ cx qcls ty ds) =
(\qcls' cx' ty' ds' -> [CInstance qcls' cx' ty' ds']) <$> trQual qcls
<*> trContext cx <*> trTypeExpr ty <*> mapM (trInstanceMethodDecl qcls ty) ds
trInstanceDecl _ = return []
trInstanceMethodDecl :: QualIdent -> TypeExpr -> Decl PredType -> GAC CFuncDecl
trInstanceMethodDecl qcls ty (FunctionDecl _ _ f eqs) = do
uacy <- S.gets untypedAcy
qty <- if uacy
then return $ QualTypeExpr [] $ ConstructorType prelUntyped
else getQualType' (qualifyLike qcls $ unRenameIdent f)
CFunc <$> trLocalIdent f <*> pure (eqnArity $ head eqs) <*> pure Public
<*> trInstanceMethodType ty qty <*> mapM trEquation eqs
trInstanceMethodDecl _ _ _ = internalError "GenAbstractCurry.trInstanceMethodDecl"
trInstanceMethodType :: TypeExpr -> QualTypeExpr -> GAC CQualTypeExpr
trInstanceMethodType ity (QualTypeExpr cx ty) =
trQualTypeExpr $ fromPredType identSupply $
subst (bindSubst 0 (toType [] ity) idSubst) $
toPredType (take 1 identSupply) $ QualTypeExpr (drop 1 cx) ty
trTypeDecl :: Decl a -> GAC [CTypeDecl]
trTypeDecl (DataDecl _ t vs cs clss) =
(\t' v vs' cs' clss' -> [CType t' v vs' cs' clss'])
<$> trGlobalIdent t <*> getTypeVisibility t
<*> mapM genTVarIndex vs <*> mapM trConsDecl cs
<*> mapM trQual clss
trTypeDecl (TypeDecl _ t vs ty) = (\t' v vs' ty' -> [CTypeSyn t' v vs' ty'])
<$> trGlobalIdent t <*> getTypeVisibility t
<*> mapM genTVarIndex vs <*> trTypeExpr ty
trTypeDecl (NewtypeDecl _ t vs nc clss) =
(\t' v vs' nc' clss' -> [CNewType t' v vs' nc' clss'])
<$> trGlobalIdent t <*> getTypeVisibility t
<*> mapM genTVarIndex vs <*> trNewConsDecl nc
<*> mapM trQual clss
trTypeDecl _ = return []
trConsDecl :: ConstrDecl -> GAC CConsDecl
trConsDecl (ConstrDecl _ vs cx c tys) = inNestedTScope $ CCons
<$> mapM genTVarIndex vs <*> trContext cx <*> trGlobalIdent c
<*> getVisibility c <*> mapM trTypeExpr tys
trConsDecl (ConOpDecl p vs cx ty1 op ty2) = inNestedTScope $ trConsDecl $
ConstrDecl p vs cx op [ty1, ty2]
trConsDecl (RecordDecl _ vs cx c fs) = inNestedTScope $ CRecord
<$> mapM genTVarIndex vs <*> trContext cx <*> trGlobalIdent c
<*> getVisibility c <*> concatMapM trFieldDecl fs
trFieldDecl :: FieldDecl -> GAC [CFieldDecl]
trFieldDecl (FieldDecl _ ls ty) = T.forM ls $ \l ->
CField <$> trGlobalIdent l <*> getVisibility l <*> trTypeExpr ty
trNewConsDecl :: NewConstrDecl -> GAC CConsDecl
trNewConsDecl (NewConstrDecl _ nc ty) = CCons [] (CContext [])
<$> trGlobalIdent nc <*> getVisibility nc <*> ((:[]) <$> trTypeExpr ty)
trNewConsDecl (NewRecordDecl p nc (l, ty)) = CRecord [] (CContext [])
<$> trGlobalIdent nc <*> getVisibility nc <*> trFieldDecl (FieldDecl p [l] ty)
trTypeExpr :: TypeExpr -> GAC CTypeExpr
trTypeExpr (ConstructorType q) = CTCons <$> trQual q
trTypeExpr (ApplyType ty1 ty2) = CTApply <$> trTypeExpr ty1 <*> trTypeExpr ty2
trTypeExpr (VariableType v) = CTVar <$> getTVarIndex v
trTypeExpr (TupleType tys) =
trTypeExpr $ foldl ApplyType (ConstructorType $ qTupleId $ length tys) tys
trTypeExpr (ListType ty) =
trTypeExpr $ ApplyType (ConstructorType qListId) ty
trTypeExpr (ArrowType ty1 ty2) = CFuncType <$> trTypeExpr ty1 <*> trTypeExpr ty2
trTypeExpr (ParenType ty) = trTypeExpr ty
trTypeExpr (ForallType _ _) = internalError "GenAbstractCurry.trTypeExpr"
trConstraint :: Constraint -> GAC CConstraint
trConstraint (Constraint q ty) = (,) <$> trQual q <*> trTypeExpr ty
trContext :: Context -> GAC CContext
trContext cx = CContext <$> mapM trConstraint cx
trQualTypeExpr :: QualTypeExpr -> GAC CQualTypeExpr
trQualTypeExpr (QualTypeExpr cx ty) =
CQualType <$> trContext cx <*> trTypeExpr ty
trInfixDecl :: Decl a -> GAC [COpDecl]
trInfixDecl (InfixDecl _ fix mprec ops) = mapM trInfix (reverse ops)
where
trInfix op = COp <$> trGlobalIdent op <*> return (cvFixity fix)
<*> return (fromInteger (mkPrec mprec))
cvFixity InfixL = CInfixlOp
cvFixity InfixR = CInfixrOp
cvFixity Infix = CInfixOp
trInfixDecl _ = return []
trFuncDecl :: Bool -> Decl PredType -> GAC [CFuncDecl]
trFuncDecl global (FunctionDecl _ pty f eqs)
= (\f' a v ty rs -> [CFunc f' a v ty rs])
<$> trFuncName global f <*> pure (eqnArity $ head eqs) <*> getVisibility f
<*> getQualType f pty <*> mapM trEquation eqs
trFuncDecl global (ExternalDecl _ vs)
= T.forM vs $ \(Var pty f) -> CFunc
<$> trFuncName global f <*> pure (arrowArity $ unpredType pty)
<*> getVisibility f <*> getQualType f pty <*> return []
trFuncDecl _ _ = return []
trFuncName :: Bool -> Ident -> GAC QName
trFuncName global = if global then trGlobalIdent else trLocalIdent
trEquation :: Equation PredType -> GAC CRule
trEquation (Equation _ lhs rhs) = inNestedScope
$ CRule <$> trLhs lhs <*> trRhs rhs
trLhs :: Lhs a -> GAC [CPattern]
trLhs = mapM trPat . snd . flatLhs
trRhs :: Rhs PredType -> GAC CRhs
trRhs (SimpleRhs _ e ds) = inNestedScope $ do
mapM_ insertDeclLhs ds
CSimpleRhs <$> trExpr e <*> concatMapM trLocalDecl ds
trRhs (GuardedRhs gs ds) = inNestedScope $ do
mapM_ insertDeclLhs ds
CGuardedRhs <$> mapM trCondExpr gs <*> concatMapM trLocalDecl ds
trCondExpr :: CondExpr PredType -> GAC (CExpr, CExpr)
trCondExpr (CondExpr _ g e) = (,) <$> trExpr g <*> trExpr e
trLocalDecls :: [Decl PredType] -> GAC [CLocalDecl]
trLocalDecls ds = do
mapM_ insertDeclLhs ds
concatMapM trLocalDecl ds
insertDeclLhs :: Decl a -> GAC ()
insertDeclLhs (PatternDecl _ p _) = mapM_ genVarIndex (bv p)
insertDeclLhs (FreeDecl _ vs) = mapM_ genVarIndex (map varIdent vs)
insertDeclLhs s@(TypeSig _ _ _) = do
uacy <- S.gets untypedAcy
S.when uacy (insertSig s)
insertDeclLhs _ = return ()
trLocalDecl :: Decl PredType -> GAC [CLocalDecl]
trLocalDecl f@(FunctionDecl _ _ _ _) = map CLocalFunc <$> trFuncDecl False f
trLocalDecl f@(ExternalDecl _ _) = map CLocalFunc <$> trFuncDecl False f
trLocalDecl (PatternDecl _ p rhs) = (\p' rhs' -> [CLocalPat p' rhs'])
<$> trPat p <*> trRhs rhs
trLocalDecl (FreeDecl _ vs) = (\vs' -> [CLocalVars vs'])
<$> mapM getVarIndex (map varIdent vs)
trLocalDecl _ = return []
insertSig :: Decl a -> GAC ()
insertSig (TypeSig _ fs qty) = do
sigs <- S.gets typeSigs
let lsigs = Map.fromList [(f, qty) | f <- fs]
S.modify $ \env -> env { typeSigs = sigs `Map.union` lsigs }
insertSig _ = return ()
trExpr :: Expression PredType -> GAC CExpr
trExpr (Literal _ l) = return (CLit $ cvLiteral l)
trExpr (Variable _ v)
| isQualified v = CSymbol <$> trQual v
| otherwise = lookupVarIndex (unqualify v) >>= \mvi -> case mvi of
Just vi -> return (CVar vi)
_ -> CSymbol <$> trQual v
trExpr (Constructor _ c) = CSymbol <$> trQual c
trExpr (Paren e) = trExpr e
trExpr (Typed e qty) = CTyped <$> trExpr e <*> trQualTypeExpr qty
trExpr (Record _ c fs) = CRecConstr <$> trQual c
<*> mapM (trField trExpr) fs
trExpr (RecordUpdate e fs) = CRecUpdate <$> trExpr e
<*> mapM (trField trExpr) fs
trExpr (Tuple es) =
trExpr $ apply (Variable undefined $ qTupleId $ length es) es
trExpr (List _ es) =
trExpr $ foldr (Apply . Apply (Constructor undefined qConsId))
(Constructor undefined qNilId)
es
trExpr (ListCompr e ds) = inNestedScope $ flip CListComp
<$> mapM trStatement ds <*> trExpr e
trExpr (EnumFrom e) =
trExpr $ apply (Variable undefined qEnumFromId) [e]
trExpr (EnumFromThen e1 e2) =
trExpr $ apply (Variable undefined qEnumFromThenId) [e1, e2]
trExpr (EnumFromTo e1 e2) =
trExpr $ apply (Variable undefined qEnumFromToId) [e1, e2]
trExpr (EnumFromThenTo e1 e2 e3) =
trExpr $ apply (Variable undefined qEnumFromThenToId) [e1, e2, e3]
trExpr (UnaryMinus e) =
trExpr $ apply (Variable undefined qNegateId) [e]
trExpr (Apply e1 e2) = CApply <$> trExpr e1 <*> trExpr e2
trExpr (InfixApply e1 op e2) = trExpr $ apply (infixOp op) [e1, e2]
trExpr (LeftSection e op) = trExpr $ apply (infixOp op) [e]
trExpr (RightSection op e) =
trExpr $ apply (Variable undefined qFlip) [infixOp op, e]
trExpr (Lambda ps e) = inNestedScope $
CLambda <$> mapM trPat ps <*> trExpr e
trExpr (Let ds e) = inNestedScope $
CLetDecl <$> trLocalDecls ds <*> trExpr e
trExpr (Do ss e) = inNestedScope $
(\ss' e' -> CDoExpr (ss' ++ [CSExpr e']))
<$> mapM trStatement ss <*> trExpr e
trExpr (IfThenElse e1 e2 e3) =
trExpr $ apply (Variable undefined qIfThenElseId) [e1, e2, e3]
trExpr (Case ct e bs) = CCase (cvCaseType ct)
<$> trExpr e <*> mapM trAlt bs
cvCaseType :: CaseType -> CCaseType
cvCaseType Flex = CFlex
cvCaseType Rigid = CRigid
trStatement :: Statement PredType -> GAC CStatement
trStatement (StmtExpr e) = CSExpr <$> trExpr e
trStatement (StmtDecl ds) = CSLet <$> trLocalDecls ds
trStatement (StmtBind p e) = flip CSPat <$> trExpr e <*> trPat p
trAlt :: Alt PredType -> GAC (CPattern, CRhs)
trAlt (Alt _ p rhs) = inNestedScope $ (,) <$> trPat p <*> trRhs rhs
trPat :: Pattern a -> GAC CPattern
trPat (LiteralPattern _ l) = return (CPLit $ cvLiteral l)
trPat (VariablePattern _ v) = CPVar <$> getVarIndex v
trPat (ConstructorPattern _ c ps) = CPComb <$> trQual c <*> mapM trPat ps
trPat (InfixPattern a p1 op p2) = trPat $ ConstructorPattern a op [p1, p2]
trPat (ParenPattern p) = trPat p
trPat (RecordPattern _ c fs) = CPRecord <$> trQual c
<*> mapM (trField trPat) fs
trPat (TuplePattern ps) =
trPat $ ConstructorPattern undefined (qTupleId $ length ps) ps
trPat (ListPattern _ ps) = trPat $
foldr (\x1 x2 -> ConstructorPattern undefined qConsId [x1, x2])
(ConstructorPattern undefined qNilId [])
ps
trPat (NegativePattern a l) = trPat $ LiteralPattern a $ negateLiteral l
trPat (AsPattern v p) = CPAs <$> getVarIndex v<*> trPat p
trPat (LazyPattern p) = CPLazy <$> trPat p
trPat (FunctionPattern _ f ps) = CPFuncComb <$> trQual f <*> mapM trPat ps
trPat (InfixFuncPattern a p1 f p2) = trPat (FunctionPattern a f [p1, p2])
trField :: (a -> GAC b) -> Field a -> GAC (CField b)
trField act (Field _ l x) = (,) <$> trQual l <*> act x
negateLiteral :: Literal -> Literal
negateLiteral (Int i) = Int (i)
negateLiteral (Float f) = Float (f)
negateLiteral _ = internalError "GenAbstractCurry.negateLiteral"
cvLiteral :: Literal -> CLiteral
cvLiteral (Char c) = CCharc c
cvLiteral (Int i) = CIntc i
cvLiteral (Float f) = CFloatc f
cvLiteral (String s) = CStringc s
trQual :: QualIdent -> GAC QName
trQual qid
| n `elem` [unitId, listId, nilId, consId] = return ("Prelude", idName n)
| isTupleId n = return ("Prelude", idName n)
| otherwise
= return (maybe "" moduleName (qidModule qid), idName n)
where n = qidIdent qid
trGlobalIdent :: Ident -> GAC QName
trGlobalIdent i = S.gets moduleId >>= \m -> return (moduleName m, idName i)
trLocalIdent :: Ident -> GAC QName
trLocalIdent i = return ("", idName i)
qFlip :: QualIdent
qFlip = qualifyWith preludeMIdent (mkIdent "flip")
qNegateId :: QualIdent
qNegateId = qualifyWith preludeMIdent (mkIdent "negate")
qIfThenElseId :: QualIdent
qIfThenElseId = qualifyWith preludeMIdent (mkIdent "if_then_else")
prelUntyped :: QualIdent
prelUntyped = qualifyWith preludeMIdent $ mkIdent "untyped"
data AbstractEnv = AbstractEnv
{ moduleId :: ModuleIdent
, typeEnv :: ValueEnv
, tyExports :: Set.Set Ident
, valExports :: Set.Set Ident
, varIndex :: Int
, tvarIndex :: Int
, varEnv :: NestEnv Int
, tvarEnv :: NestEnv Int
, untypedAcy :: Bool
, typeSigs :: Map.Map Ident QualTypeExpr
} deriving Show
abstractEnv :: Bool -> CompilerEnv -> Module a -> AbstractEnv
abstractEnv uacy env (Module _ mid es _ ds) = AbstractEnv
{ moduleId = mid
, typeEnv = valueEnv env
, tyExports = foldr (buildTypeExports mid) Set.empty es'
, valExports = foldr (buildValueExports mid) Set.empty es'
, varIndex = 0
, tvarIndex = 0
, varEnv = globalEnv emptyTopEnv
, tvarEnv = globalEnv emptyTopEnv
, untypedAcy = uacy
, typeSigs = if uacy
then Map.fromList $ signatures ds
else Map.empty
}
where es' = case es of
Just (Exporting _ e) -> e
_ -> internalError "GenAbstractCurry.abstractEnv"
buildTypeExports :: ModuleIdent -> Export -> Set.Set Ident -> Set.Set Ident
buildTypeExports mid (ExportTypeWith tc _)
| isLocalIdent mid tc = Set.insert (unqualify tc)
buildTypeExports _ _ = id
buildValueExports :: ModuleIdent -> Export -> Set.Set Ident -> Set.Set Ident
buildValueExports mid (Export q)
| isLocalIdent mid q = Set.insert (unqualify q)
buildValueExports mid (ExportTypeWith tc cs)
| isLocalIdent mid tc = flip (foldr Set.insert) cs
buildValueExports _ _ = id
lookupVarIndex :: Ident -> GAC (Maybe CVarIName)
lookupVarIndex i = S.gets $ \env -> case lookupNestEnv i $ varEnv env of
[v] -> Just (v, idName i)
_ -> Nothing
getVarIndex :: Ident -> GAC CVarIName
getVarIndex i = S.get >>= \env -> case lookupNestEnv i $ varEnv env of
[v] -> return (v, idName i)
_ -> genVarIndex i
genVarIndex :: Ident -> GAC CVarIName
genVarIndex i = do
env <- S.get
let idx = varIndex env
S.put $ env { varIndex = idx + 1, varEnv = bindNestEnv i idx (varEnv env) }
return (idx, idName i)
getTVarIndex :: Ident -> GAC CTVarIName
getTVarIndex i = S.get >>= \env -> case lookupNestEnv i $ tvarEnv env of
[v] -> return (v, idName i)
_ -> genTVarIndex i
genTVarIndex :: Ident -> GAC CTVarIName
genTVarIndex i = do
env <- S.get
let idx = tvarIndex env
S.put $ env { tvarIndex = idx + 1, tvarEnv = bindNestEnv i idx (tvarEnv env) }
return (idx, idName i)
withLocalEnv :: GAC a -> GAC a
withLocalEnv act = do
old <- S.get
res <- act
S.put old
return res
inNestedScope :: GAC a -> GAC a
inNestedScope act = do
(vo, to) <- S.gets $ \e -> (varEnv e, tvarEnv e)
S.modify $ \e -> e { varEnv = nestEnv $ vo, tvarEnv = globalEnv emptyTopEnv }
res <- act
S.modify $ \e -> e { varEnv = vo, tvarEnv = to }
return res
inNestedTScope :: GAC a -> GAC a
inNestedTScope act = do
(vo, to) <- S.gets $ \e -> (varEnv e, tvarEnv e)
S.modify $ \e -> e { varEnv = globalEnv emptyTopEnv, tvarEnv = nestEnv $ to }
res <- act
S.modify $ \e -> e { varEnv = vo, tvarEnv = to }
return res
getQualType :: Ident -> PredType -> GAC CQualTypeExpr
getQualType f pty = do
uacy <- S.gets untypedAcy
sigs <- S.gets typeSigs
trQualTypeExpr $ case uacy of
True -> Maybe.fromMaybe (QualTypeExpr [] $ ConstructorType prelUntyped)
(Map.lookup f sigs)
False -> fromPredType identSupply pty
getQualType' :: QualIdent -> GAC QualTypeExpr
getQualType' f = do
m <- S.gets moduleId
tyEnv <- S.gets typeEnv
return $ case qualLookupValue f tyEnv of
[Value _ _ _ (ForAll _ pty)] -> fromPredType identSupply pty
_ -> case qualLookupValue (qualQualify m f) tyEnv of
[Value _ _ _ (ForAll _ pty)] -> fromPredType identSupply pty
_ ->
internalError $ "GenAbstractCurry.getQualType': " ++ show f
getTypeVisibility :: Ident -> GAC CVisibility
getTypeVisibility i = S.gets $ \env ->
if Set.member i (tyExports env) then Public else Private
getVisibility :: Ident -> GAC CVisibility
getVisibility i = S.gets $ \env ->
if Set.member i (valExports env) then Public else Private
signatures :: [Decl a] -> [(Ident, QualTypeExpr)]
signatures ds = [(f, qty) | TypeSig _ fs qty <- ds, f <- fs]