module Transformations.Desugar (desugar) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Arrow (first, second)
import Control.Monad (mplus)
import qualified Control.Monad.State as S (State, runState, gets, modify)
import Data.List ((\\), elemIndex, nub, tails)
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set (Set, empty, member, insert)
import Curry.Base.Ident
import Curry.Base.Position hiding (first)
import Curry.Syntax
import Base.Expr
import Base.CurryTypes (toType, fromType)
import Base.Messages (internalError)
import Base.Types
import Base.TypeSubst (expandType)
import Base.Typing
import Base.Utils (mapAccumM, concatMapM)
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
import Env.Value (ValueEnv, ValueInfo (..), bindFun, qualLookupValue, conType)
desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module -> (Module, ValueEnv)
desugar xs tyEnv tcEnv (Module ps m es is ds)
= (Module ps m es is ds', valueEnv s')
where (ds', s') = S.runState (desugarModuleDecls ds)
(DesugarState m xs tcEnv tyEnv 1)
data DesugarState = DesugarState
{ moduleIdent :: ModuleIdent
, extensions :: [KnownExtension]
, tyConsEnv :: TCEnv
, valueEnv :: ValueEnv
, nextId :: Integer
}
type DsM a = S.State DesugarState a
getModuleIdent :: DsM ModuleIdent
getModuleIdent = S.gets moduleIdent
checkNegativeLitsExtension :: DsM Bool
checkNegativeLitsExtension = S.gets (\s -> NegativeLiterals `elem` extensions s)
getTyConsEnv :: DsM TCEnv
getTyConsEnv = S.gets tyConsEnv
getValueEnv :: DsM ValueEnv
getValueEnv = S.gets valueEnv
modifyValueEnv :: (ValueEnv -> ValueEnv) -> DsM ()
modifyValueEnv f = S.modify $ \ s -> s { valueEnv = f $ valueEnv s }
getNextId :: DsM Integer
getNextId = do
nid <- S.gets nextId
S.modify $ \ s -> s { nextId = succ nid }
return nid
getTypeOf :: Typeable t => t -> DsM Type
getTypeOf t = do
tyEnv <- getValueEnv
return (typeOf tyEnv t)
freshIdent :: String -> Int -> TypeScheme -> DsM Ident
freshIdent prefix arity ty = do
m <- getModuleIdent
x <- (mkIdent . (prefix ++) . show) <$> getNextId
modifyValueEnv $ bindFun m x arity ty
return x
freshMonoTypeVar :: Typeable t => String -> t -> DsM Ident
freshMonoTypeVar prefix t = getTypeOf t >>= \ ty ->
freshIdent prefix (arrowArity ty) (monoType ty)
desugarModuleDecls :: [Decl] -> DsM [Decl]
desugarModuleDecls ds = do
ds' <- concatMapM dsRecordDecl ds
ds'' <- dsDeclGroup ds'
return $ filter isTypeDecl ds' ++ ds''
dsRecordDecl :: Decl -> DsM [Decl]
dsRecordDecl (DataDecl p tc tvs cs) = do
m <- getModuleIdent
let qcs = map (qualifyWith m . constrId) cs
selFuns <- mapM (genSelFun p qcs) (nub $ concatMap recordLabels cs)
return $ DataDecl p tc tvs (map unlabelConstr cs) : selFuns
dsRecordDecl (NewtypeDecl p tc tvs nc) = do
m <- getModuleIdent
let qc = qualifyWith m (nconstrId nc)
selFun <- mapM (genSelFun p [qc]) (nrecordLabels nc)
return $ NewtypeDecl p tc tvs (unlabelNewConstr nc) : selFun
dsRecordDecl d = return [d]
genSelFun :: Position -> [QualIdent] -> Ident -> DsM Decl
genSelFun p qcs l = FunctionDecl p l <$> concatMapM (genSelEqn p l) qcs
genSelEqn :: Position -> Ident -> QualIdent -> DsM [Equation]
genSelEqn p l qc = do
tyEnv <- getValueEnv
let (ls, ty) = conType qc tyEnv
(tys, _) = arrowUnapply (instType ty)
case elemIndex l ls of
Just n -> do vs <- mapM (freshMonoTypeVar "_#rec") tys
let pat = ConstructorPattern qc (map VariablePattern vs)
return [mkEquation p l [pat] (mkVar (vs !! n))]
Nothing -> return []
unlabelConstr :: ConstrDecl -> ConstrDecl
unlabelConstr (RecordDecl p evs c fs) = ConstrDecl p evs c tys
where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls]
unlabelConstr c = c
unlabelNewConstr :: NewConstrDecl -> NewConstrDecl
unlabelNewConstr (NewRecordDecl p evs nc (_, ty)) = NewConstrDecl p evs nc ty
unlabelNewConstr c = c
dsDeclGroup :: [Decl] -> DsM [Decl]
dsDeclGroup ds = concatMapM dsDeclLhs (filter isValueDecl ds) >>= mapM dsDeclRhs
dsDeclLhs :: Decl -> DsM [Decl]
dsDeclLhs (PatternDecl p t rhs) = do
(ds', t') <- dsPat p [] t
dss' <- mapM dsDeclLhs ds'
return $ PatternDecl p t' rhs : concat dss'
dsDeclLhs (ExternalDecl p fs) = mapM (genForeignDecl p) fs
dsDeclLhs d = return [d]
genForeignDecl :: Position -> Ident -> DsM Decl
genForeignDecl p f = do
m <- getModuleIdent
ty <- fromType <$> (getTypeOf $ Variable $ qual m f)
return $ ForeignDecl p CallConvPrimitive (Just $ idName f) f ty
where
qual m f'
| hasGlobalScope f' = qualifyWith m f'
| otherwise = qualify f'
dsDeclRhs :: Decl -> DsM Decl
dsDeclRhs (FunctionDecl p f eqs) = FunctionDecl p f <$> mapM dsEquation eqs
dsDeclRhs (PatternDecl p t rhs) = PatternDecl p t <$> dsRhs p id rhs
dsDeclRhs (ForeignDecl p cc ie f ty) = return $ ForeignDecl p cc ie' f ty
where ie' = ie `mplus` Just (idName f)
dsDeclRhs fs@(FreeDecl _ _) = return fs
dsDeclRhs _ = error "Desugar.dsDeclRhs: no pattern match"
dsEquation :: Equation -> DsM Equation
dsEquation (Equation p lhs rhs) = do
( cs1, ts1) <- dsNonLinearity ts
(ds1, cs2, ts2) <- dsFunctionalPatterns p ts1
(ds2, ts3) <- mapAccumM (dsPat p) [] ts2
rhs' <- dsRhs p (constrain cs2 . constrain cs1)
(addDecls (ds1 ++ ds2) rhs)
return $ Equation p (FunLhs f ts3) rhs'
where (f, ts) = flatLhs lhs
constrain :: [Expression] -> Expression -> Expression
constrain cs e = if null cs then e else foldr1 (&) cs &> e
dsRhs :: Position -> (Expression -> Expression) -> Rhs -> DsM Rhs
dsRhs p f rhs = expandRhs prelFailed f rhs
>>= dsExpr pRhs
>>= return . simpleRhs pRhs
where
pRhs = fromMaybe p (getRhsPosition rhs)
expandRhs :: Expression -> (Expression -> Expression) -> Rhs -> DsM Expression
expandRhs _ f (SimpleRhs _ e ds) = return $ Let ds (f e)
expandRhs e0 f (GuardedRhs es ds) = (Let ds . f) <$> expandGuards e0 es
expandGuards :: Expression -> [CondExpr] -> DsM Expression
expandGuards e0 es = do
tyEnv <- getValueEnv
return $ if boolGuards tyEnv es then foldr mkIfThenElse e0 es else mkCond es
where
mkIfThenElse (CondExpr p g e) = IfThenElse (srcRefOf p) g e
mkCond [CondExpr _ g e] = g &> e
mkCond _ = error "Desugar.expandGuards.mkCond: non-unary list"
boolGuards :: ValueEnv -> [CondExpr] -> Bool
boolGuards _ [] = False
boolGuards tyEnv (CondExpr _ g _ : es) = not (null es) ||
typeOf tyEnv g == boolType
addDecls :: [Decl] -> Rhs -> Rhs
addDecls ds (SimpleRhs p e ds') = SimpleRhs p e (ds ++ ds')
addDecls ds (GuardedRhs es ds') = GuardedRhs es (ds ++ ds')
getRhsPosition :: Rhs -> Maybe Position
getRhsPosition (SimpleRhs p _ _) = Just p
getRhsPosition (GuardedRhs _ _) = Nothing
dsNonLinearity :: [Pattern] -> DsM ([Expression], [Pattern])
dsNonLinearity ts = do
((_, cs), ts') <- mapAccumM dsNonLinear (Set.empty, []) ts
return (reverse cs, ts')
type NonLinearEnv = (Set.Set Ident, [Expression])
dsNonLinear :: NonLinearEnv -> Pattern -> DsM (NonLinearEnv, Pattern)
dsNonLinear env l@(LiteralPattern _) = return (env, l)
dsNonLinear env n@(NegativePattern _ _) = return (env, n)
dsNonLinear env t@(VariablePattern v)
| isAnonId v = return (env, t)
| v `Set.member` vis = do
v' <- freshMonoTypeVar "_#nonlinear" t
return ((vis, mkStrictEquality v v' : eqs), VariablePattern v')
| otherwise = return ((Set.insert v vis, eqs), t)
where (vis, eqs) = env
dsNonLinear env (ConstructorPattern c ts) = second (ConstructorPattern c)
<$> mapAccumM dsNonLinear env ts
dsNonLinear env (InfixPattern t1 op t2) = do
(env1, t1') <- dsNonLinear env t1
(env2, t2') <- dsNonLinear env1 t2
return (env2, InfixPattern t1' op t2')
dsNonLinear env (ParenPattern t) = second ParenPattern
<$> dsNonLinear env t
dsNonLinear env (RecordPattern c fs) =
second (RecordPattern c) <$> mapAccumM (dsField dsNonLinear) env fs
dsNonLinear env (TuplePattern pos ts) = second (TuplePattern pos)
<$> mapAccumM dsNonLinear env ts
dsNonLinear env (ListPattern pos ts) = second (ListPattern pos)
<$> mapAccumM dsNonLinear env ts
dsNonLinear env (AsPattern v t) = do
(env1, VariablePattern v') <- dsNonLinear env (VariablePattern v)
(env2, t' ) <- dsNonLinear env1 t
return (env2, AsPattern v' t')
dsNonLinear env (LazyPattern r t) = second (LazyPattern r)
<$> dsNonLinear env t
dsNonLinear env fp@(FunctionPattern _ _) = dsNonLinearFuncPat env fp
dsNonLinear env fp@(InfixFuncPattern _ _ _) = dsNonLinearFuncPat env fp
dsNonLinearFuncPat :: NonLinearEnv -> Pattern -> DsM (NonLinearEnv, Pattern)
dsNonLinearFuncPat (vis, eqs) fp = do
let fpVars = bv fp
vs = filter (`Set.member` vis) fpVars
vs' <- mapM (freshMonoTypeVar "_#nonlinear" . VariablePattern) vs
let vis' = foldr Set.insert vis fpVars
fp' = substPat (zip vs vs') fp
return ((vis', zipWith mkStrictEquality vs vs' ++ eqs), fp')
mkStrictEquality :: Ident -> Ident -> Expression
mkStrictEquality x y = mkVar x =:= mkVar y
substPat :: [(Ident, Ident)] -> Pattern -> Pattern
substPat _ l@(LiteralPattern _) = l
substPat _ n@(NegativePattern _ _) = n
substPat s (VariablePattern v) = VariablePattern
$ fromMaybe v (lookup v s)
substPat s (ConstructorPattern c ps) = ConstructorPattern c
$ map (substPat s) ps
substPat s (InfixPattern p1 op p2) = InfixPattern (substPat s p1) op
(substPat s p2)
substPat s (ParenPattern p) = ParenPattern (substPat s p)
substPat s (RecordPattern c fs) = RecordPattern c (map substField fs)
where substField (Field pos l pat) = Field pos l (substPat s pat)
substPat s (TuplePattern pos ps) = TuplePattern pos $ map (substPat s) ps
substPat s (ListPattern pos ps) = ListPattern pos $ map (substPat s) ps
substPat s (AsPattern v p) = AsPattern (fromMaybe v (lookup v s))
(substPat s p)
substPat s (LazyPattern r p) = LazyPattern r (substPat s p)
substPat s (FunctionPattern f ps) = FunctionPattern f $ map (substPat s) ps
substPat s (InfixFuncPattern p1 op p2) = InfixFuncPattern (substPat s p1) op
(substPat s p2)
dsFunctionalPatterns :: Position -> [Pattern]
-> DsM ([Decl], [Expression], [Pattern])
dsFunctionalPatterns p ts = do
(bs, ts') <- mapAccumM elimFP [] ts
let (ds, cs) = genFPExpr p (bv ts') (reverse bs)
return (ds, cs, ts')
type LazyBinding = (Pattern, Ident)
elimFP :: [LazyBinding] -> Pattern -> DsM ([LazyBinding], Pattern)
elimFP bs p@(LiteralPattern _) = return (bs, p)
elimFP bs p@(NegativePattern _ _) = return (bs, p)
elimFP bs p@(VariablePattern _) = return (bs, p)
elimFP bs (ConstructorPattern c ts) = second (ConstructorPattern c)
<$> mapAccumM elimFP bs ts
elimFP bs (InfixPattern t1 op t2) = do
(bs1, t1') <- elimFP bs t1
(bs2, t2') <- elimFP bs1 t2
return (bs2, InfixPattern t1' op t2')
elimFP bs (ParenPattern t) = second ParenPattern <$> elimFP bs t
elimFP bs (RecordPattern c fs) = second (RecordPattern c)
<$> mapAccumM (dsField elimFP) bs fs
elimFP bs (TuplePattern pos ts) = second (TuplePattern pos)
<$> mapAccumM elimFP bs ts
elimFP bs (ListPattern pos ts) = second (ListPattern pos)
<$> mapAccumM elimFP bs ts
elimFP bs (AsPattern v t) = second (AsPattern v) <$> elimFP bs t
elimFP bs (LazyPattern r t) = second (LazyPattern r) <$> elimFP bs t
elimFP bs p@(FunctionPattern _ _) = do
v <- freshMonoTypeVar "_#funpatt" p
return ((p, v) : bs, VariablePattern v)
elimFP bs p@(InfixFuncPattern _ _ _) = do
v <- freshMonoTypeVar "_#funpatt" p
return ((p, v) : bs, VariablePattern v)
genFPExpr :: Position -> [Ident] -> [LazyBinding] -> ([Decl], [Expression])
genFPExpr p vs bs
| null bs = ([] , [])
| null free = ([] , cs)
| otherwise = ([FreeDecl p free], cs)
where
mkLB (t, v) = let (t', es) = fp2Expr t
in (t' =:<= mkVar v) : es
cs = concatMap mkLB bs
free = nub $ filter (not . isAnonId) $ bv (map fst bs) \\ vs
fp2Expr :: Pattern -> (Expression, [Expression])
fp2Expr (LiteralPattern l) = (Literal l, [])
fp2Expr (NegativePattern _ l) = (Literal (negateLiteral l), [])
fp2Expr (VariablePattern v) = (mkVar v, [])
fp2Expr (ConstructorPattern c ts) =
let (ts', ess) = unzip $ map fp2Expr ts
in (apply (Constructor c) ts', concat ess)
fp2Expr (InfixPattern t1 op t2) =
let (t1', es1) = fp2Expr t1
(t2', es2) = fp2Expr t2
in (InfixApply t1' (InfixConstr op) t2', es1 ++ es2)
fp2Expr (ParenPattern t) = first Paren (fp2Expr t)
fp2Expr (TuplePattern r ts) =
let (ts', ess) = unzip $ map fp2Expr ts
in (Tuple r ts', concat ess)
fp2Expr (ListPattern rs ts) =
let (ts', ess) = unzip $ map fp2Expr ts
in (List rs ts', concat ess)
fp2Expr (FunctionPattern f ts) =
let (ts', ess) = unzip $ map fp2Expr ts
in (apply (Variable f) ts', concat ess)
fp2Expr (InfixFuncPattern t1 op t2) =
let (t1', es1) = fp2Expr t1
(t2', es2) = fp2Expr t2
in (InfixApply t1' (InfixOp op) t2', es1 ++ es2)
fp2Expr (AsPattern v t) =
let (t', es) = fp2Expr t
in (mkVar v, (t' =:<= mkVar v) : es)
fp2Expr (RecordPattern c fs) =
let (fs', ess) = unzip [ (Field p f e, es) | Field p f t <- fs
, let (e, es) = fp2Expr t]
in (Record c fs', concat ess)
fp2Expr t = internalError $
"Desugar.fp2Expr: Unexpected constructor term: " ++ show t
dsPat :: Position -> [Decl] -> Pattern -> DsM ([Decl], Pattern)
dsPat _ ds v@(VariablePattern _) = return (ds, v)
dsPat p ds (LiteralPattern l) = dsLiteral l >>= \dl -> case dl of
Left l' -> return (ds, LiteralPattern l')
Right (rs, ls) -> dsPat p ds $ ListPattern rs $ map LiteralPattern ls
dsPat p ds (NegativePattern _ l) = dsPat p ds
(LiteralPattern (negateLiteral l))
dsPat p ds (ConstructorPattern c [t]) = do
isNc <- isNewtypeConstr c
if isNc then dsPat p ds t else second (constrPat c) <$> dsPat p ds t
where constrPat c' t' = ConstructorPattern c' [t']
dsPat p ds (ConstructorPattern c ts) =
second (ConstructorPattern c) <$> mapAccumM (dsPat p) ds ts
dsPat p ds (InfixPattern t1 op t2) =
dsPat p ds (ConstructorPattern op [t1, t2])
dsPat p ds (ParenPattern t) = dsPat p ds t
dsPat p ds (RecordPattern c fs) = do
tyEnv <- getValueEnv
let ls = map (qualifyLike c) $ fst $ conType c tyEnv
ts = map (dsLabel (VariablePattern anonId) (map field2Tuple fs)) ls
dsPat p ds (ConstructorPattern c ts)
dsPat p ds (TuplePattern pos ts) =
dsPat p ds (ConstructorPattern (tupleConstr ts) ts)
where tupleConstr ts' = addRef pos $
if null ts' then qUnitId else qTupleId (length ts')
dsPat p ds (ListPattern pos ts) =
second (dsList pos cons nil) <$> mapAccumM (dsPat p) ds ts
where nil p' = ConstructorPattern (addRef p' qNilId) []
cons p' t ts' = ConstructorPattern (addRef p' qConsId) [t,ts']
dsPat p ds (AsPattern v t) = dsAs p v <$> dsPat p ds t
dsPat p ds (LazyPattern r t) = dsLazy r p ds t
dsPat p ds (FunctionPattern f ts) = second (FunctionPattern f)
<$> mapAccumM (dsPat p) ds ts
dsPat p ds (InfixFuncPattern t1 f t2) = dsPat p ds (FunctionPattern f [t1,t2])
dsAs :: Position -> Ident -> ([Decl], Pattern) -> ([Decl], Pattern)
dsAs p v (ds, t) = case t of
VariablePattern v' -> (varDecl p v (mkVar v') : ds, t)
AsPattern v' _ -> (varDecl p v (mkVar v') : ds, t)
_ -> (ds, AsPattern v t)
dsLazy :: SrcRef -> Position -> [Decl] -> Pattern -> DsM ([Decl], Pattern)
dsLazy pos p ds t = case t of
VariablePattern _ -> return (ds, t)
ParenPattern t' -> dsLazy pos p ds t'
AsPattern v t' -> dsAs p v <$> dsLazy pos p ds t'
LazyPattern pos' t' -> dsLazy pos' p ds t'
_ -> do
v' <- addPositionIdent (AST pos) <$> freshMonoTypeVar "_#lazy" t
return (patDecl p { astRef = pos } t (mkVar v') : ds, VariablePattern v')
dsExpr :: Position -> Expression -> DsM Expression
dsExpr p (Literal l) =
dsLiteral l >>=
either (return . Literal) (\ (rs, ls) -> dsExpr p $ List rs $ map Literal ls)
dsExpr _ var@(Variable v)
| isAnonId (unqualify v) = return prelUnknown
| otherwise = return var
dsExpr _ c@(Constructor _) = return c
dsExpr p (Paren e) = dsExpr p e
dsExpr p (Typed e ty) = Typed <$> dsExpr p e <*> dsTypeExpr ty
dsExpr p (Record c fs) = do
tyEnv <- getValueEnv
let ls = map (qualifyLike c) $ fst $ conType c tyEnv
es = map (dsLabel prelUnknown (map field2Tuple fs)) ls
dsExpr p $ apply (Constructor c) es
dsExpr p (RecordUpdate e fs) = do
TypeConstructor tc _ <- arrowBase <$> getTypeOf e
alts <- constructors tc >>= concatMapM (updateAlt tc)
dsExpr p $ Case (srcRefOf p) Flex e (map (uncurry (caseAlt p)) alts)
where
updateAlt tc' (RecordConstr c _ labels tys)
| all (`elem` qls) (map fieldLabel fs) = do
vs <- mapM (freshMonoTypeVar "_#rec") tys
let qc = qualifyLike tc' c
pat = ConstructorPattern qc (map VariablePattern vs)
es = zipWith (\v l -> dsLabel (mkVar v) (map field2Tuple fs) l) vs qls
return [(pat, apply (Constructor qc) es)]
where qls = map (qualifyLike tc') labels
updateAlt _ _ = return []
dsExpr p (Tuple pos es) = apply (Constructor $ tupleConstr es)
<$> mapM (dsExpr p) es
where tupleConstr es1 = addRef pos
$ if null es1 then qUnitId else qTupleId (length es1)
dsExpr p (List pos es) = dsList pos cons nil <$> mapM (dsExpr p) es
where nil p' = Constructor (addRef p' qNilId)
cons p' = Apply . Apply (Constructor (addRef p' qConsId))
dsExpr p (ListCompr r e qs) = dsListComp p r e qs
dsExpr p (EnumFrom e) = Apply prelEnumFrom <$> dsExpr p e
dsExpr p (EnumFromThen e1 e2) = apply prelEnumFromThen
<$> mapM (dsExpr p) [e1, e2]
dsExpr p (EnumFromTo e1 e2) = apply prelEnumFromTo
<$> mapM (dsExpr p) [e1, e2]
dsExpr p (EnumFromThenTo e1 e2 e3) = apply prelEnumFromThenTo
<$> mapM (dsExpr p) [e1, e2, e3]
dsExpr p (UnaryMinus op e) = do
ty <- getTypeOf e
e' <- dsExpr p e
negativeLitsEnabled <- checkNegativeLitsExtension
return $ case e' of
Literal l | negativeLitsEnabled -> Literal $ negateLiteral l
_ -> Apply (unaryMinus op ty) e'
where
unaryMinus op1 ty'
| op1 == minusId = if ty' == floatType then prelNegateFloat else prelNegate
| op1 == fminusId = prelNegateFloat
| otherwise = internalError "Desugar.unaryMinus"
dsExpr p (Apply (Constructor c) e) = do
isNc <- isNewtypeConstr c
if isNc then dsExpr p e else Apply (Constructor c) <$> dsExpr p e
dsExpr p (Apply e1 e2) = Apply <$> dsExpr p e1 <*> dsExpr p e2
dsExpr p (InfixApply e1 op e2) = do
op' <- dsExpr p (infixOp op)
e1' <- dsExpr p e1
e2' <- dsExpr p e2
return $ apply op' [e1', e2']
dsExpr p (LeftSection e op) = Apply <$> dsExpr p (infixOp op) <*> dsExpr p e
dsExpr p (RightSection op e) = do
op' <- dsExpr p (infixOp op)
e' <- dsExpr p e
return $ apply prelFlip [op', e']
dsExpr p expr@(Lambda r ts e) = do
ty <- getTypeOf expr
f <- freshIdent "_#lambda" (length ts) (polyType ty)
dsExpr p $ Let [funDecl (AST r) f ts e] $ mkVar f
dsExpr p (Let ds e) = do
ds' <- dsDeclGroup ds
e' <- dsExpr p e
return (if null ds' then e' else Let ds' e')
dsExpr p (Do sts e) = dsExpr p (dsDo sts e)
dsExpr p (IfThenElse r e1 e2 e3) = do
e1' <- dsExpr p e1
e2' <- dsExpr p e2
e3' <- dsExpr p e3
return $ Case r Rigid e1' [caseAlt p truePat e2', caseAlt p falsePat e3']
dsExpr p (Case r ct e alts) = dsCase p r ct e alts
dsTypeExpr :: TypeExpr -> DsM TypeExpr
dsTypeExpr ty = do
tcEnv <- getTyConsEnv
return $ fromType (expandType tcEnv (toType [] ty))
dsCase :: Position -> SrcRef -> CaseType -> Expression -> [Alt] -> DsM Expression
dsCase p r ct e alts
| null alts = return prelFailed
| otherwise = do
m <- getModuleIdent
e' <- dsExpr p e
v <- freshMonoTypeVar "_#case" e
alts' <- mapM dsAltLhs alts
alts'' <- mapM (expandAlt v ct) (init (tails alts')) >>= mapM dsAltRhs
return (mkCase m v e' alts'')
where
mkCase m v e' bs
| v `elem` qfv m bs = Let [varDecl p v e'] (Case r ct (mkVar v) bs)
| otherwise = Case r ct e' bs
dsAltLhs :: Alt -> DsM Alt
dsAltLhs (Alt p t rhs) = do
(ds', t') <- dsPat p [] t
return $ Alt p t' (addDecls ds' rhs)
dsAltRhs :: Alt -> DsM Alt
dsAltRhs (Alt p t rhs) = Alt p t <$> dsRhs p id rhs
expandAlt :: Ident -> CaseType -> [Alt] -> DsM Alt
expandAlt _ _ [] = error "Desugar.expandAlt: empty list"
expandAlt v ct (Alt p t rhs : alts) = caseAlt p t <$> expandRhs e0 id rhs
where
e0 | ct == Flex = prelFailed
| otherwise = Case (srcRefOf p) ct (mkVar v)
(filter (isCompatible t . altPattern) alts)
altPattern (Alt _ t1 _) = t1
isCompatible :: Pattern -> Pattern -> Bool
isCompatible (VariablePattern _) _ = True
isCompatible _ (VariablePattern _) = True
isCompatible (AsPattern _ t1) t2 = isCompatible t1 t2
isCompatible t1 (AsPattern _ t2) = isCompatible t1 t2
isCompatible (ConstructorPattern c1 ts1) (ConstructorPattern c2 ts2)
= and ((c1 == c2) : zipWith isCompatible ts1 ts2)
isCompatible (LiteralPattern l1) (LiteralPattern l2)
= canon l1 == canon l2
where canon (Int _ i) = Int anonId i
canon l = l
isCompatible _ _ = False
dsDo :: [Statement] -> Expression -> Expression
dsDo sts e = foldr dsStmt e sts
where
dsStmt (StmtExpr r e1) e' = apply (prelBind_ r) [e1, e']
dsStmt (StmtBind r t e1) e' = apply (prelBind r) [e1, Lambda r [t] e']
dsStmt (StmtDecl ds) e' = Let ds e'
dsListComp :: Position -> SrcRef -> Expression -> [Statement] -> DsM Expression
dsListComp p r e [] = dsExpr p (List [r,r] [e])
dsListComp p r e (q:qs) = dsQual p q (ListCompr r e qs)
dsQual :: Position -> Statement -> Expression -> DsM Expression
dsQual p (StmtExpr r b) e = dsExpr p (IfThenElse r b e (List [r] []))
dsQual p (StmtDecl ds) e = dsExpr p (Let ds e)
dsQual p (StmtBind r t l) e
| isVarPattern t = dsExpr p (qualExpr t e l)
| otherwise = do
v <- addRefId r <$> freshMonoTypeVar "_#var" t
l' <- addRefId r <$> freshMonoTypeVar "_#var" e
dsExpr p (apply (prelFoldr r) [foldFunct v l' e, List [r] [], l])
where
qualExpr v (ListCompr _ e1 []) l1 = apply (prelMap r)
[Lambda r [v] e1, l1]
qualExpr v e1 l1 = apply (prelConcatMap r)
[Lambda r [v] e1, l1]
foldFunct v l1 e1
= Lambda r (map VariablePattern [v,l1])
(Case r Rigid (mkVar v)
[ caseAlt p t (append e1 (mkVar l1))
, caseAlt p (VariablePattern v) (mkVar l1)])
append (ListCompr _ e1 []) l1 = apply prelCons [e1, l1]
append e1 l1 = apply (prelAppend r) [e1, l1]
prelCons = Constructor $ addRef r $ qConsId
dsList :: [SrcRef] -> (SrcRef -> b -> b -> b) -> (SrcRef -> b) -> [b] -> b
dsList pos cons nil xs = snd (foldr cons' nil' xs)
where rNil : rCs = reverse pos
nil' = (rCs , nil rNil)
cons' t (rC:rCs',ts) = (rCs', cons rC t ts)
cons' _ ([],_) = error "Desugar.dsList.cons': empty list"
dsLabel :: a -> [(QualIdent, a)] -> QualIdent -> a
dsLabel def fs l = fromMaybe def (lookup l fs)
dsField :: (a -> b -> DsM (a, b)) -> a -> Field b -> DsM (a, Field b)
dsField ds z (Field p l x) = second (Field p l) <$> (ds z x)
dsLiteral :: Literal -> DsM (Either Literal ([SrcRef], [Literal]))
dsLiteral c@(Char _ _) = return $ Left c
dsLiteral (Int v i) = do
tyEnv <- getValueEnv
return (Left (fixType tyEnv))
where
fixType tyEnv | typeOf tyEnv v == floatType = Float (srcRefOf $ idPosition v)
(fromIntegral i)
| otherwise = Int v i
dsLiteral f@(Float _ _) = return $ Left f
dsLiteral (String (SrcRef [i]) cs) = return $ Right
(consRefs i cs, zipWith (Char . SrcRef . (:[])) [i, i + 2 ..] cs)
where consRefs r [] = [SrcRef [r]]
consRefs r (_:xs) = let r' = r + 2
in r' `seq` (SrcRef [r'] : consRefs r' xs)
dsLiteral (String is _) = internalError $
"Desugar.dsLiteral: " ++ "wrong source ref for string " ++ show is
negateLiteral :: Literal -> Literal
negateLiteral (Int v i) = Int v (i)
negateLiteral (Float p' f) = Float p' (f)
negateLiteral _ = internalError "Desugar.negateLiteral"
prel :: String -> SrcRef -> Expression
prel s r = Variable $ addRef r $ preludeIdent s
prelude :: String -> Expression
prelude = Variable . preludeIdent
preludeIdent :: String -> QualIdent
preludeIdent = qualifyWith preludeMIdent . mkIdent
prelBind :: SrcRef -> Expression
prelBind = prel ">>="
prelBind_ :: SrcRef -> Expression
prelBind_ = prel ">>"
prelFlip :: Expression
prelFlip = prelude "flip"
prelEnumFrom :: Expression
prelEnumFrom = prelude "enumFrom"
prelEnumFromTo :: Expression
prelEnumFromTo = prelude "enumFromTo"
prelEnumFromThen :: Expression
prelEnumFromThen = prelude "enumFromThen"
prelEnumFromThenTo :: Expression
prelEnumFromThenTo = prelude "enumFromThenTo"
prelFailed :: Expression
prelFailed = prelude "failed"
prelUnknown :: Expression
prelUnknown = prelude "unknown"
prelMap :: SrcRef -> Expression
prelMap = prel "map"
prelFoldr :: SrcRef -> Expression
prelFoldr = prel "foldr"
prelAppend :: SrcRef -> Expression
prelAppend = prel "++"
prelConcatMap :: SrcRef -> Expression
prelConcatMap = prel "concatMap"
prelNegate :: Expression
prelNegate = prelude "negate"
prelNegateFloat :: Expression
prelNegateFloat = prelude "negateFloat"
(=:<=) :: Expression -> Expression -> Expression
e1 =:<= e2 = apply (prelude "=:<=") [e1, e2]
(=:=) :: Expression -> Expression -> Expression
e1 =:= e2 = apply (prelude "=:=") [e1, e2]
(&>) :: Expression -> Expression -> Expression
e1 &> e2 = apply (prelude "cond") [e1, e2]
(&) :: Expression -> Expression -> Expression
e1 & e2 = apply (prelude "&") [e1, e2]
truePat :: Pattern
truePat = ConstructorPattern qTrueId []
falsePat :: Pattern
falsePat = ConstructorPattern qFalseId []
isNewtypeConstr :: QualIdent -> DsM Bool
isNewtypeConstr c = getValueEnv >>= \tyEnv -> return $
case qualLookupValue c tyEnv of
[NewtypeConstructor _ _ _] -> True
[DataConstructor _ _ _ _] -> False
x -> internalError $ "Transformations.Desugar.isNewtypeConstr: "
++ show c ++ " is " ++ show x
isVarPattern :: Pattern -> Bool
isVarPattern (VariablePattern _) = True
isVarPattern (ParenPattern t) = isVarPattern t
isVarPattern (AsPattern _ t) = isVarPattern t
isVarPattern (LazyPattern _ _) = True
isVarPattern _ = False
funDecl :: Position -> Ident -> [Pattern] -> Expression -> Decl
funDecl p f ts e = FunctionDecl p f [mkEquation p f ts e]
mkEquation :: Position -> Ident -> [Pattern] -> Expression -> Equation
mkEquation p f ts e = Equation p (FunLhs f ts) (simpleRhs p e)
patDecl :: Position -> Pattern -> Expression -> Decl
patDecl p t e = PatternDecl p t (simpleRhs p e)
varDecl :: Position -> Ident -> Expression -> Decl
varDecl p = patDecl p . VariablePattern
caseAlt :: Position -> Pattern -> Expression -> Alt
caseAlt p t e = Alt p t (simpleRhs p e)
simpleRhs :: Position -> Expression -> Rhs
simpleRhs p e = SimpleRhs p e []
apply :: Expression -> [Expression] -> Expression
apply = foldl Apply
mkVar :: Ident -> Expression
mkVar = Variable . qualify
instType :: ExistTypeScheme -> Type
instType (ForAllExist _ _ ty) = inst ty
where inst (TypeConstructor tc tys) = TypeConstructor tc (map inst tys)
inst (TypeVariable tv) = TypeVariable (1 tv)
inst (TypeArrow ty1 ty2) = TypeArrow (inst ty1) (inst ty2)
inst ty' = ty'
constructors :: QualIdent -> DsM [DataConstr]
constructors c = getTyConsEnv >>= \tcEnv -> return $
case qualLookupTC c tcEnv of
[DataType _ _ cs] -> cs
[RenamingType _ _ nc] -> [nc]
_ -> internalError $
"Transformations.Desugar.constructors: " ++ show c