module Generators.GenAbstractCurry (genAbstractCurry) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
#endif
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 (fromMaybe)
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 (fromType)
import Base.Expr (bv)
import Base.Messages (internalError)
import Base.NestEnv
import Base.Types (TypeScheme (..))
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
import Env.OpPrec (mkPrec)
import CompilerEnv
type GAC a = S.State AbstractEnv a
genAbstractCurry :: Bool -> CompilerEnv -> Module -> CurryProg
genAbstractCurry uacy env mdl
= S.evalState (trModule mdl) (abstractEnv uacy env mdl)
trModule :: Module -> GAC CurryProg
trModule (Module _ mid _ is ds) = do
CurryProg mid' is' <$> ts' <*> fs' <*> os'
where
mid' = moduleName mid
is' = map cvImportDecl is
ts' = concat <$> mapM (withLocalEnv . trTypeDecl ) ds
fs' = concat <$> mapM (withLocalEnv . trFuncDecl True) ds
os' = concat <$> mapM (withLocalEnv . trInfixDecl) ds
cvImportDecl :: ImportDecl -> String
cvImportDecl (ImportDecl _ mid _ _ _) = moduleName mid
trTypeDecl :: Decl -> GAC [CTypeDecl]
trTypeDecl (DataDecl _ t vs cs) = (\t' v vs' cs' -> [CType t' v vs' cs'])
<$> trGlobalIdent t <*> getTypeVisibility t
<*> mapM genTVarIndex vs <*> mapM trConsDecl cs
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) = (\t' v vs' nc' -> [CNewType t' v vs' nc'])
<$> trGlobalIdent t <*> getTypeVisibility t
<*> mapM genTVarIndex vs <*> trNewConsDecl nc
trTypeDecl _ = return []
trConsDecl :: ConstrDecl -> GAC CConsDecl
trConsDecl (ConstrDecl _ _ c tys) = CCons
<$> trGlobalIdent c <*> getVisibility c <*> mapM trTypeExpr tys
trConsDecl (ConOpDecl p vs ty1 op ty2) = trConsDecl $
ConstrDecl p vs op [ty1, ty2]
trConsDecl (RecordDecl _ _ c fs) = CRecord
<$> trGlobalIdent c <*> getVisibility c <*> (concat <$> mapM 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
<$> trGlobalIdent nc <*> getVisibility nc <*> ((:[]) <$> trTypeExpr ty)
trNewConsDecl (NewRecordDecl p _ nc (l, ty)) = CRecord
<$> trGlobalIdent nc <*> getVisibility nc <*> trFieldDecl (FieldDecl p [l] ty)
trTypeExpr :: TypeExpr -> GAC CTypeExpr
trTypeExpr (ConstructorType q ts) = CTCons <$> trQual q
<*> mapM trTypeExpr ts
trTypeExpr (VariableType v) = CTVar <$> getTVarIndex v
trTypeExpr (TupleType tys) = trTypeExpr $ case tys of
[] -> ConstructorType qUnitId []
[ty] -> ty
_ -> ConstructorType (qTupleId $ length tys) tys
trTypeExpr (ListType ty) = trTypeExpr $ ConstructorType qListId [ty]
trTypeExpr (ArrowType ty1 ty2) = CFuncType <$> trTypeExpr ty1
<*> trTypeExpr ty2
trTypeExpr (ParenType ty) = trTypeExpr ty
trInfixDecl :: Decl -> 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 -> GAC [CFuncDecl]
trFuncDecl global (FunctionDecl _ f eqs)
= (\f' a v ty rs -> [CFunc f' a v ty rs])
<$> trFuncName global f <*> getArity f <*> getVisibility f
<*> getType f <*> mapM trEquation eqs
trFuncDecl global (ForeignDecl _ _ _ f _)
= (\f' a v ty rs -> [CFunc f' a v ty rs])
<$> trFuncName global f <*> getArity f <*> getVisibility f
<*> getType f <*> return []
trFuncDecl global (ExternalDecl _ fs) = T.forM fs $ \f -> CFunc
<$> trFuncName global f <*> getArity f <*> getVisibility f
<*> getType f <*> return []
trFuncDecl _ _ = return []
trFuncName :: Bool -> Ident -> GAC QName
trFuncName global = if global then trGlobalIdent else trLocalIdent
trEquation :: Equation -> GAC CRule
trEquation (Equation _ lhs rhs) = inNestedScope
$ CRule <$> trLhs lhs <*> trRhs rhs
trLhs :: Lhs -> GAC [CPattern]
trLhs = mapM trPat . snd . flatLhs
trRhs :: Rhs -> GAC CRhs
trRhs (SimpleRhs _ e ds) = inNestedScope $ do
mapM_ insertDeclLhs ds
CSimpleRhs <$> trExpr e <*> (concat <$> mapM trLocalDecl ds)
trRhs (GuardedRhs gs ds) = inNestedScope $ do
mapM_ insertDeclLhs ds
CGuardedRhs <$> mapM trCondExpr gs <*> (concat <$> mapM trLocalDecl ds)
trCondExpr :: CondExpr -> GAC (CExpr, CExpr)
trCondExpr (CondExpr _ g e) = (,) <$> trExpr g <*> trExpr e
trLocalDecls :: [Decl] -> GAC [CLocalDecl]
trLocalDecls ds = do
mapM_ insertDeclLhs ds
concat <$> mapM trLocalDecl ds
insertDeclLhs :: Decl -> GAC ()
insertDeclLhs (PatternDecl _ p _) = mapM_ genVarIndex (bv p)
insertDeclLhs (FreeDecl _ vs) = mapM_ genVarIndex vs
insertDeclLhs s@(TypeSig _ _ _) = do
uacy <- S.gets untypedAcy
S.when uacy (insertSig s)
insertDeclLhs _ = return ()
trLocalDecl :: Decl -> GAC [CLocalDecl]
trLocalDecl f@(FunctionDecl _ _ _) = map CLocalFunc <$> trFuncDecl False f
trLocalDecl f@(ForeignDecl _ _ _ _ _) = 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 vs
trLocalDecl _ = return []
insertSig :: Decl -> GAC ()
insertSig (TypeSig _ fs ty) = do
sigs <- S.gets typeSigs
let lsigs = Map.fromList [(f, ty) | f <- fs]
S.modify $ \env -> env { typeSigs = sigs `Map.union` lsigs }
insertSig _ = return ()
trExpr :: Expression -> 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 ty) = CTyped <$> trExpr e <*> trTypeExpr ty
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 $ case es of
[] -> Variable qUnitId
[x] -> x
_ -> foldl Apply (Variable $ qTupleId $ length es) es
trExpr (List _ es) = trExpr $
foldr (Apply . Apply (Constructor qConsId)) (Constructor qNilId) es
trExpr (ListCompr _ e ds) = inNestedScope $ flip CListComp
<$> mapM trStatement ds <*> trExpr e
trExpr (EnumFrom e) = trExpr
$ apply (Variable qEnumFromId ) [e]
trExpr (EnumFromThen e1 e2) = trExpr
$ apply (Variable qEnumFromThenId ) [e1,e2]
trExpr (EnumFromTo e1 e2) = trExpr
$ apply (Variable qEnumFromToId ) [e1,e2]
trExpr (EnumFromThenTo e1 e2 e3) = trExpr
$ apply (Variable qEnumFromThenToId) [e1,e2,e3]
trExpr (UnaryMinus _ e) = trExpr $ apply (Variable qNegateId) [e]
trExpr (Apply e1 e2) = CApply <$> trExpr e1 <*> trExpr e2
trExpr (InfixApply e1 op e2) = trExpr $ apply (opToExpr op) [e1, e2]
trExpr (LeftSection e op) = trExpr $ apply (opToExpr op) [e]
trExpr (RightSection op e) = trExpr
$ apply (Variable qFlip) [opToExpr 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 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
apply :: Expression -> [Expression] -> Expression
apply = foldl Apply
trStatement :: Statement -> 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 -> GAC (CPattern, CRhs)
trAlt (Alt _ p rhs) = inNestedScope $ (,) <$> trPat p <*> trRhs rhs
trPat :: Pattern -> 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 p1 op p2) = trPat $ ConstructorPattern op [p1, p2]
trPat (ParenPattern p) = trPat p
trPat (RecordPattern c fs) = CPRecord <$> trQual c
<*> mapM (trField trPat) fs
trPat (TuplePattern _ ps) = trPat $ case ps of
[] -> ConstructorPattern qUnitId []
[ty] -> ty
_ -> ConstructorPattern (qTupleId $ length ps) ps
trPat (ListPattern _ ps) = trPat $
foldr (\x1 x2 -> ConstructorPattern qConsId [x1, x2])
(ConstructorPattern qNilId [])
ps
trPat (NegativePattern _ l) = trPat $ LiteralPattern $ 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 p1 f p2) = trPat (FunctionPattern 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 v i) = Int v (i)
negateLiteral (Float p' f) = Float p' (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)
opToExpr :: InfixOp -> Expression
opToExpr (InfixOp op) = Variable op
opToExpr (InfixConstr c) = Constructor c
qFlip :: QualIdent
qFlip = qualifyWith preludeMIdent (mkIdent "flip")
qEnumFromId :: QualIdent
qEnumFromId = qualifyWith preludeMIdent (mkIdent "enumFrom")
qEnumFromThenId :: QualIdent
qEnumFromThenId = qualifyWith preludeMIdent (mkIdent "enumFromThen")
qEnumFromToId :: QualIdent
qEnumFromToId = qualifyWith preludeMIdent (mkIdent "enumFromTo")
qEnumFromThenToId :: QualIdent
qEnumFromThenToId = qualifyWith preludeMIdent (mkIdent "enumFromThenTo")
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 :: TopEnv Int
, untypedAcy :: Bool
, typeSigs :: Map.Map Ident TypeExpr
} deriving Show
abstractEnv :: Bool -> CompilerEnv -> Module -> 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 = emptyTopEnv
, untypedAcy = uacy
, typeSigs = if uacy
then Map.fromList [ (f, ty) | TypeSig _ fs ty <- ds, f <- fs]
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 lookupTopEnv 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 = bindTopEnv 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 = emptyTopEnv }
res <- act
S.modify $ \e -> e { varEnv = vo, tvarEnv = to }
return res
getArity :: Ident -> GAC Int
getArity f = do
m <- S.gets moduleId
tyEnv <- S.gets typeEnv
return $ case lookupValue f tyEnv of
[Value _ a _] -> a
_ -> case qualLookupValue (qualifyWith m f) tyEnv of
[Value _ a _] -> a
_ -> internalError $ "GenAbstractCurry.getArity: " ++ show f
getType :: Ident -> GAC CTypeExpr
getType f = S.gets untypedAcy >>= getType' f >>= trTypeExpr
getType' :: Ident -> Bool -> GAC TypeExpr
getType' f True = do
sigs <- S.gets typeSigs
return $ Maybe.fromMaybe (ConstructorType prelUntyped []) (Map.lookup f sigs)
getType' f False = do
m <- S.gets moduleId
tyEnv <- S.gets typeEnv
return $ case lookupValue f tyEnv of
[Value _ _ (ForAll _ ty)] -> fromType ty
_ -> case qualLookupValue (qualifyWith m f) tyEnv of
[Value _ _ (ForAll _ ty)] -> fromType ty
_ -> internalError $ "GenAbstractCurry.getType: "
++ 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