module Transformations.Desugar (desugar) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Arrow (first, second)
import Control.Monad (liftM2)
import Control.Monad.Extra (concatMapM)
import qualified Control.Monad.State as S (State, runState, gets, modify)
import Data.Foldable (foldrM)
import Data.List ( (\\), elemIndex, nub, partition
, 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
import Base.Messages (internalError)
import Base.TypeExpansion
import Base.Types
import Base.TypeSubst
import Base.Typing
import Base.Utils (fst3, mapAccumM)
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTypeInfo)
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module PredType
-> (Module PredType, ValueEnv)
desugar xs vEnv 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 vEnv 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
getNextId :: DsM Integer
getNextId = do
nid <- S.gets nextId
S.modify $ \s -> s { nextId = succ nid }
return nid
freshVar :: Typeable t => String -> t -> DsM (PredType, Ident)
freshVar prefix t = do
v <- (mkIdent . (prefix ++) . show) <$> getNextId
return (predType $ typeOf t, v)
desugarModuleDecls :: [Decl PredType] -> DsM [Decl PredType]
desugarModuleDecls ds = do
ds' <- concatMapM dsRecordDecl ds
ds'' <- mapM dsClassAndInstanceDecl ds'
ds''' <- dsDeclGroup ds''
return $ filter (not . liftM2 (||) isValueDecl isTypeSig) ds'' ++ ds'''
dsClassAndInstanceDecl :: Decl PredType -> DsM (Decl PredType)
dsClassAndInstanceDecl (ClassDecl p cx cls tv ds) =
ClassDecl p cx cls tv . (tds ++) <$> dsDeclGroup vds
where (tds, vds) = partition isTypeSig ds
dsClassAndInstanceDecl (InstanceDecl p cx cls ty ds) =
InstanceDecl p cx cls ty <$> dsDeclGroup ds
dsClassAndInstanceDecl d = return d
dsRecordDecl :: Decl PredType -> DsM [Decl PredType]
dsRecordDecl (DataDecl p tc tvs cs clss) = 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) clss : selFuns
dsRecordDecl (NewtypeDecl p tc tvs nc clss) = do
m <- getModuleIdent
let qc = qualifyWith m (nconstrId nc)
selFun <- mapM (genSelFun p [qc]) (nrecordLabels nc)
return $ NewtypeDecl p tc tvs (unlabelNewConstr nc) clss : selFun
dsRecordDecl d = return [d]
genSelFun :: Position -> [QualIdent] -> Ident -> DsM (Decl PredType)
genSelFun p qcs l = do
m <- getModuleIdent
vEnv <- getValueEnv
let ForAll _ pty = varType (qualifyWith m l) vEnv
FunctionDecl p pty l <$> concatMapM (genSelEqn p l) qcs
genSelEqn :: Position -> Ident -> QualIdent -> DsM [Equation PredType]
genSelEqn p l qc = do
vEnv <- getValueEnv
let (ls, ty) = conType qc vEnv
(tys, ty0) = arrowUnapply (instType ty)
case elemIndex l ls of
Just n -> do
vs <- mapM (freshVar "_#rec") tys
let pat = constrPattern (predType ty0) qc vs
return [mkEquation p l [pat] (uncurry mkVar (vs !! n))]
Nothing -> return []
unlabelConstr :: ConstrDecl -> ConstrDecl
unlabelConstr (RecordDecl p evs cx c fs) = ConstrDecl p evs cx c tys
where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls]
unlabelConstr c = c
unlabelNewConstr :: NewConstrDecl -> NewConstrDecl
unlabelNewConstr (NewRecordDecl p nc (_, ty)) = NewConstrDecl p nc ty
unlabelNewConstr c = c
dsDeclGroup :: [Decl PredType] -> DsM [Decl PredType]
dsDeclGroup ds = concatMapM dsDeclLhs (filter isValueDecl ds) >>= mapM dsDeclRhs
dsDeclLhs :: Decl PredType -> DsM [Decl PredType]
dsDeclLhs (PatternDecl p t rhs) = do
(ds', t') <- dsPat p [] t
dss' <- mapM dsDeclLhs ds'
return $ PatternDecl p t' rhs : concat dss'
dsDeclLhs d = return [d]
dsDeclRhs :: Decl PredType -> DsM (Decl PredType)
dsDeclRhs (FunctionDecl p pty f eqs) =
FunctionDecl p pty f <$> mapM dsEquation eqs
dsDeclRhs (PatternDecl p t rhs) = PatternDecl p t <$> dsRhs p id rhs
dsDeclRhs d@(FreeDecl _ _) = return d
dsDeclRhs d@(ExternalDecl _ _) = return d
dsDeclRhs _ =
error "Desugar.dsDeclRhs: no pattern match"
dsEquation :: Equation PredType -> DsM (Equation PredType)
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 PredType] -> Expression PredType -> Expression PredType
constrain cs e = if null cs then e else foldr1 (&) cs &> e
dsRhs :: Position -> (Expression PredType -> Expression PredType)
-> Rhs PredType -> DsM (Rhs PredType)
dsRhs p f rhs = expandRhs (prelFailed (typeOf rhs)) f rhs
>>= dsExpr pRhs
>>= return . simpleRhs pRhs
where
pRhs = fromMaybe p (getRhsPosition rhs)
expandRhs :: Expression PredType -> (Expression PredType -> Expression PredType)
-> Rhs PredType -> DsM (Expression PredType)
expandRhs _ f (SimpleRhs _ e ds) = return $ Let ds (f e)
expandRhs e0 f (GuardedRhs es ds) = (Let ds . f) <$> expandGuards e0 es
expandGuards :: Expression PredType -> [CondExpr PredType]
-> DsM (Expression PredType)
expandGuards e0 es =
return $ if boolGuards es then foldr mkIfThenElse e0 es else mkCond es
where
mkIfThenElse (CondExpr _ g e) = IfThenElse g e
mkCond [CondExpr _ g e] = g &> e
mkCond _ = error "Desugar.expandGuards.mkCond: non-unary list"
boolGuards :: [CondExpr PredType] -> Bool
boolGuards [] = False
boolGuards (CondExpr _ g _ : es) = not (null es) || typeOf g == boolType
addDecls :: [Decl PredType] -> Rhs PredType -> Rhs PredType
addDecls ds (SimpleRhs p e ds') = SimpleRhs p e (ds ++ ds')
addDecls ds (GuardedRhs es ds') = GuardedRhs es (ds ++ ds')
getRhsPosition :: Rhs a -> Maybe Position
getRhsPosition (SimpleRhs p _ _) = Just p
getRhsPosition (GuardedRhs _ _) = Nothing
dsNonLinearity :: [Pattern PredType]
-> DsM ([Expression PredType], [Pattern PredType])
dsNonLinearity ts = do
((_, cs), ts') <- mapAccumM dsNonLinear (Set.empty, []) ts
return (reverse cs, ts')
type NonLinearEnv = (Set.Set Ident, [Expression PredType])
dsNonLinear :: NonLinearEnv -> Pattern PredType
-> DsM (NonLinearEnv, Pattern PredType)
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' <- freshVar "_#nonlinear" t
return ((vis, mkStrictEquality v v' : eqs), uncurry VariablePattern v')
| otherwise = return ((Set.insert v vis, eqs), t)
where (vis, eqs) = env
dsNonLinear env (ConstructorPattern pty c ts) = second (ConstructorPattern pty c)
<$> mapAccumM dsNonLinear env ts
dsNonLinear env (InfixPattern pty t1 op t2) = do
(env1, t1') <- dsNonLinear env t1
(env2, t2') <- dsNonLinear env1 t2
return (env2, InfixPattern pty t1' op t2')
dsNonLinear env (ParenPattern t) = second ParenPattern
<$> dsNonLinear env t
dsNonLinear env (RecordPattern pty c fs) =
second (RecordPattern pty c) <$> mapAccumM (dsField dsNonLinear) env fs
dsNonLinear env (TuplePattern ts) = second TuplePattern
<$> mapAccumM dsNonLinear env ts
dsNonLinear env (ListPattern pty ts) = second (ListPattern pty)
<$> mapAccumM dsNonLinear env ts
dsNonLinear env (AsPattern v t) = do
let pty = predType $ typeOf t
(env1, VariablePattern _ v') <- dsNonLinear env (VariablePattern pty v)
(env2, t') <- dsNonLinear env1 t
return (env2, AsPattern v' t')
dsNonLinear env (LazyPattern t) = second LazyPattern
<$> dsNonLinear env t
dsNonLinear env fp@(FunctionPattern _ _ _) = dsNonLinearFuncPat env fp
dsNonLinear env fp@(InfixFuncPattern _ _ _ _) = dsNonLinearFuncPat env fp
dsNonLinearFuncPat :: NonLinearEnv -> Pattern PredType
-> DsM (NonLinearEnv, Pattern PredType)
dsNonLinearFuncPat (vis, eqs) fp = do
let fpVars = map (\(v, _, pty) -> (pty, v)) $ patternVars fp
vs = filter ((`Set.member` vis) . snd) fpVars
vs' <- mapM (freshVar "_#nonlinear" . uncurry VariablePattern) vs
let vis' = foldr (Set.insert . snd) vis fpVars
fp' = substPat (zip (map snd vs) (map snd vs')) fp
return ((vis', zipWith mkStrictEquality (map snd vs) vs' ++ eqs), fp')
mkStrictEquality :: Ident -> (PredType, Ident) -> Expression PredType
mkStrictEquality x (pty, y) = mkVar pty x =:= mkVar pty y
substPat :: [(Ident, Ident)] -> Pattern a -> Pattern a
substPat _ l@(LiteralPattern _ _) = l
substPat _ n@(NegativePattern _ _) = n
substPat s (VariablePattern a v) = VariablePattern a
$ fromMaybe v (lookup v s)
substPat s (ConstructorPattern a c ps) = ConstructorPattern a c
$ map (substPat s) ps
substPat s (InfixPattern a p1 op p2) = InfixPattern a (substPat s p1) op
(substPat s p2)
substPat s (ParenPattern p) = ParenPattern (substPat s p)
substPat s (RecordPattern a c fs) = RecordPattern a c (map substField fs)
where substField (Field pos l pat) = Field pos l (substPat s pat)
substPat s (TuplePattern ps) = TuplePattern
$ map (substPat s) ps
substPat s (ListPattern a ps) = ListPattern a
$ map (substPat s) ps
substPat s (AsPattern v p) = AsPattern (fromMaybe v (lookup v s))
(substPat s p)
substPat s (LazyPattern p) = LazyPattern (substPat s p)
substPat s (FunctionPattern a f ps) = FunctionPattern a f
$ map (substPat s) ps
substPat s (InfixFuncPattern a p1 op p2) = InfixFuncPattern a (substPat s p1) op
(substPat s p2)
dsFunctionalPatterns
:: Position -> [Pattern PredType]
-> DsM ([Decl PredType], [Expression PredType], [Pattern PredType])
dsFunctionalPatterns p ts = do
(bs, ts') <- mapAccumM elimFP [] ts
let (ds, cs) = genFPExpr p (concatMap patternVars ts') (reverse bs)
return (ds, cs, ts')
type LazyBinding = (Pattern PredType, (PredType, Ident))
elimFP :: [LazyBinding] -> Pattern PredType
-> DsM ([LazyBinding], Pattern PredType)
elimFP bs p@(LiteralPattern _ _) = return (bs, p)
elimFP bs p@(NegativePattern _ _) = return (bs, p)
elimFP bs p@(VariablePattern _ _) = return (bs, p)
elimFP bs (ConstructorPattern pty c ts) = second (ConstructorPattern pty c)
<$> mapAccumM elimFP bs ts
elimFP bs (InfixPattern pty t1 op t2) = do
(bs1, t1') <- elimFP bs t1
(bs2, t2') <- elimFP bs1 t2
return (bs2, InfixPattern pty t1' op t2')
elimFP bs (ParenPattern t) = second ParenPattern <$> elimFP bs t
elimFP bs (RecordPattern pty c fs) = second (RecordPattern pty c)
<$> mapAccumM (dsField elimFP) bs fs
elimFP bs (TuplePattern ts) = second TuplePattern
<$> mapAccumM elimFP bs ts
elimFP bs (ListPattern pty ts) = second (ListPattern pty)
<$> mapAccumM elimFP bs ts
elimFP bs (AsPattern v t) = second (AsPattern v) <$> elimFP bs t
elimFP bs (LazyPattern t) = second LazyPattern <$> elimFP bs t
elimFP bs p@(FunctionPattern _ _ _) = do
(pty, v) <- freshVar "_#funpatt" p
return ((p, (pty, v)) : bs, VariablePattern pty v)
elimFP bs p@(InfixFuncPattern _ _ _ _) = do
(pty, v) <- freshVar "_#funpatt" p
return ((p, (pty, v)) : bs, VariablePattern pty v)
genFPExpr :: Position -> [(Ident, Int, PredType)] -> [LazyBinding]
-> ([Decl PredType], [Expression PredType])
genFPExpr p vs bs
| null bs = ([] , [])
| null free = ([] , cs)
| otherwise = ([FreeDecl p (map (\(v, _, pty) -> Var pty v) free)], cs)
where
mkLB (t, (pty, v)) = let (t', es) = fp2Expr t
in (t' =:<= mkVar pty v) : es
cs = concatMap mkLB bs
free = nub $ filter (not . isAnonId . fst3) $
concatMap patternVars (map fst bs) \\ vs
fp2Expr :: Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr (LiteralPattern pty l) = (Literal pty l, [])
fp2Expr (NegativePattern pty l) = (Literal pty (negateLiteral l), [])
fp2Expr (VariablePattern pty v) = (mkVar pty v, [])
fp2Expr (ConstructorPattern pty c ts) =
let (ts', ess) = unzip $ map fp2Expr ts
pty' = predType $ foldr TypeArrow (unpredType pty) $ map typeOf ts
in (apply (Constructor pty' c) ts', concat ess)
fp2Expr (InfixPattern pty t1 op t2) =
let (t1', es1) = fp2Expr t1
(t2', es2) = fp2Expr t2
pty' = predType $ foldr TypeArrow (unpredType pty) [typeOf t1, typeOf t2]
in (InfixApply t1' (InfixConstr pty' op) t2', es1 ++ es2)
fp2Expr (ParenPattern t) = first Paren (fp2Expr t)
fp2Expr (TuplePattern ts) =
let (ts', ess) = unzip $ map fp2Expr ts
in (Tuple ts', concat ess)
fp2Expr (ListPattern pty ts) =
let (ts', ess) = unzip $ map fp2Expr ts
in (List pty ts', concat ess)
fp2Expr (FunctionPattern pty f ts) =
let (ts', ess) = unzip $ map fp2Expr ts
pty' = predType $ foldr TypeArrow (unpredType pty) $ map typeOf ts
in (apply (Variable pty' f) ts', concat ess)
fp2Expr (InfixFuncPattern pty t1 op t2) =
let (t1', es1) = fp2Expr t1
(t2', es2) = fp2Expr t2
pty' = predType $ foldr TypeArrow (unpredType pty) $ map typeOf [t1, t2]
in (InfixApply t1' (InfixOp pty' op) t2', es1 ++ es2)
fp2Expr (AsPattern v t) =
let (t', es) = fp2Expr t
pty = predType $ typeOf t
in (mkVar pty v, (t' =:<= mkVar pty v) : es)
fp2Expr (RecordPattern pty c fs) =
let (fs', ess) = unzip [ (Field p f e, es) | Field p f t <- fs
, let (e, es) = fp2Expr t]
in (Record pty c fs', concat ess)
fp2Expr t = internalError $
"Desugar.fp2Expr: Unexpected constructor term: " ++ show t
dsLiteralPat :: PredType -> Literal
-> Either (Pattern PredType) (Pattern PredType)
dsLiteralPat pty c@(Char _) = Right (LiteralPattern pty c)
dsLiteralPat pty (Int i) =
Right (LiteralPattern pty (fixLiteral (unpredType pty)))
where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
fixLiteral ty
| ty == floatType = Float $ fromInteger i
| otherwise = Int i
dsLiteralPat pty f@(Float _) = Right (LiteralPattern pty f)
dsLiteralPat pty (String cs) =
Left $ ListPattern pty $ map (LiteralPattern pty' . Char) cs
where pty' = predType $ elemType $ unpredType pty
dsPat :: Position -> [Decl PredType] -> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat _ ds v@(VariablePattern _ _) = return (ds, v)
dsPat p ds (LiteralPattern pty l) =
either (dsPat p ds) (return . (,) ds) (dsLiteralPat pty l)
dsPat p ds (NegativePattern pty l) =
dsPat p ds (LiteralPattern pty (negateLiteral l))
dsPat p ds (ConstructorPattern pty c ts) =
second (ConstructorPattern pty c) <$> mapAccumM (dsPat p) ds ts
dsPat p ds (InfixPattern pty t1 op t2) =
dsPat p ds (ConstructorPattern pty op [t1, t2])
dsPat p ds (ParenPattern t) = dsPat p ds t
dsPat p ds (RecordPattern pty c fs) = do
vEnv <- getValueEnv
let (ls, tys) = argumentTypes (unpredType pty) c vEnv
tsMap = map field2Tuple fs
anonTs = map (flip VariablePattern anonId . predType) tys
maybeTs = map (flip lookup tsMap) ls
ts = zipWith fromMaybe anonTs maybeTs
dsPat p ds (ConstructorPattern pty c ts)
dsPat p ds (TuplePattern ts) =
dsPat p ds (ConstructorPattern pty (qTupleId $ length ts) ts)
where pty = predType (tupleType (map typeOf ts))
dsPat p ds (ListPattern pty ts) =
second (dsList cons nil) <$> mapAccumM (dsPat p) ds ts
where nil = ConstructorPattern pty qNilId []
cons t ts' = ConstructorPattern pty qConsId [t, ts']
dsPat p ds (AsPattern v t) = dsAs p v <$> dsPat p ds t
dsPat p ds (LazyPattern t) = dsLazy p ds t
dsPat p ds (FunctionPattern pty f ts) = second (FunctionPattern pty f)
<$> mapAccumM (dsPat p) ds ts
dsPat p ds (InfixFuncPattern pty t1 f t2) =
dsPat p ds (FunctionPattern pty f [t1, t2])
dsAs :: Position -> Ident -> ([Decl PredType], Pattern PredType)
-> ([Decl PredType], Pattern PredType)
dsAs p v (ds, t) = case t of
VariablePattern pty v' -> (varDecl p pty v (mkVar pty v') : ds, t)
AsPattern v' t' -> (varDecl p pty' v (mkVar pty' v') : ds, t)
where pty' = predType $ typeOf t'
_ -> (ds, AsPattern v t)
dsLazy :: Position -> [Decl PredType] -> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsLazy p ds t = case t of
VariablePattern _ _ -> return (ds, t)
ParenPattern t' -> dsLazy p ds t'
AsPattern v t' -> dsAs p v <$> dsLazy p ds t'
LazyPattern t' -> dsLazy p ds t'
_ -> do
(pty, v') <- freshVar "_#lazy" t
return (patDecl p t (mkVar pty v') : ds, VariablePattern pty v')
dsExpr :: Position -> Expression PredType -> DsM (Expression PredType)
dsExpr p (Literal pty l) =
either (dsExpr p) return (dsLiteral pty l)
dsExpr _ var@(Variable pty v)
| isAnonId (unqualify v) = return $ prelUnknown $ unpredType pty
| otherwise = return var
dsExpr _ c@(Constructor _ _) = return c
dsExpr p (Paren e) = dsExpr p e
dsExpr p (Typed e qty) = Typed <$> dsExpr p e <*> dsQualTypeExpr qty
dsExpr p (Record pty c fs) = do
vEnv <- getValueEnv
let (ls, tys) = argumentTypes (unpredType pty) c vEnv
esMap = map field2Tuple fs
unknownEs = map prelUnknown tys
maybeEs = map (flip lookup esMap) ls
es = zipWith fromMaybe unknownEs maybeEs
dsExpr p (applyConstr pty c tys es)
dsExpr p (RecordUpdate e fs) = do
alts <- constructors tc >>= concatMapM updateAlt
dsExpr p $ Case Flex e (map (uncurry (caseAlt p)) alts)
where ty = typeOf e
pty = predType ty
tc = rootOfType (arrowBase ty)
updateAlt (RecordConstr c _ _ ls _)
| all (`elem` qls2) (map fieldLabel fs)= do
let qc = qualifyLike tc c
vEnv <- getValueEnv
let (qls, tys) = argumentTypes ty qc vEnv
vs <- mapM (freshVar "_#rec") tys
let pat = constrPattern pty qc vs
esMap = map field2Tuple fs
originalEs = map (uncurry mkVar) vs
maybeEs = map (flip lookup esMap) qls
es = zipWith fromMaybe originalEs maybeEs
return [(pat, applyConstr pty qc tys es)]
where qls2 = map (qualifyLike tc) ls
updateAlt _ = return []
dsExpr p (Tuple es) = apply (Constructor pty $ qTupleId $ length es) <$> mapM (dsExpr p) es
where pty = predType (foldr TypeArrow (tupleType tys) tys)
tys = map typeOf es
dsExpr p (List pty es) = dsList cons nil <$> mapM (dsExpr p) es
where nil = Constructor pty qNilId
cons = Apply . Apply (Constructor (predType $ consType $ elemType $ unpredType pty) qConsId)
dsExpr p (ListCompr e qs) = dsListComp p e qs
dsExpr p (EnumFrom e) = Apply (prelEnumFrom (typeOf e))
<$> dsExpr p e
dsExpr p (EnumFromThen e1 e2) = apply (prelEnumFromThen (typeOf e1))
<$> mapM (dsExpr p) [e1, e2]
dsExpr p (EnumFromTo e1 e2) = apply (prelEnumFromTo (typeOf e1))
<$> mapM (dsExpr p) [e1, e2]
dsExpr p (EnumFromThenTo e1 e2 e3) = apply (prelEnumFromThenTo (typeOf e1))
<$> mapM (dsExpr p) [e1, e2, e3]
dsExpr p (UnaryMinus e) = do
e' <- dsExpr p e
negativeLitsEnabled <- checkNegativeLitsExtension
return $ case e' of
Literal pty l | negativeLitsEnabled -> Literal pty $ negateLiteral l
_ -> Apply (prelNegate $ typeOf e') 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 ty1 ty2 ty3) [op', e']
where TypeArrow ty1 (TypeArrow ty2 ty3) = typeOf (infixOp op)
dsExpr p expr@(Lambda ts e) = do
(pty, f) <- freshVar "_#lambda" expr
dsExpr p $ Let [funDecl NoPos pty f ts e] $ mkVar pty 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) = dsDo sts e >>= dsExpr p
dsExpr p (IfThenElse e1 e2 e3) = do
e1' <- dsExpr p e1
e2' <- dsExpr p e2
e3' <- dsExpr p e3
return $ Case Rigid e1' [caseAlt p truePat e2', caseAlt p falsePat e3']
dsExpr p (Case ct e alts) = dsCase p ct e alts
dsQualTypeExpr :: QualTypeExpr -> DsM QualTypeExpr
dsQualTypeExpr (QualTypeExpr cx ty) = QualTypeExpr cx <$> dsTypeExpr ty
dsTypeExpr :: TypeExpr -> DsM TypeExpr
dsTypeExpr ty = do
m <- getModuleIdent
tcEnv <- getTyConsEnv
return $ fromType (typeVariables ty) (expandType m tcEnv (toType [] ty))
dsCase :: Position -> CaseType -> Expression PredType -> [Alt PredType]
-> DsM (Expression PredType)
dsCase p ct e alts
| null alts = internalError "Desugar.dsCase: empty list of alternatives"
| otherwise = do
m <- getModuleIdent
e' <- dsExpr p e
v <- freshVar "_#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 (pty, v) e' bs
| v `elem` qfv m bs = Let [varDecl p pty v e'] (Case ct (mkVar pty v) bs)
| otherwise = Case ct e' bs
dsAltLhs :: Alt PredType -> DsM (Alt PredType)
dsAltLhs (Alt p t rhs) = do
(ds', t') <- dsPat p [] t
return $ Alt p t' (addDecls ds' rhs)
dsAltRhs :: Alt PredType -> DsM (Alt PredType)
dsAltRhs (Alt p t rhs) = Alt p t <$> dsRhs p id rhs
expandAlt :: (PredType, Ident) -> CaseType -> [Alt PredType]
-> DsM (Alt PredType)
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 || null compAlts = prelFailed (typeOf rhs)
| otherwise = Case ct (uncurry mkVar v) compAlts
compAlts = filter (isCompatible t . altPattern) alts
altPattern (Alt _ t1 _) = t1
isCompatible :: Pattern a -> Pattern a -> 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) = l1 == l2
isCompatible _ _ = False
dsDo :: [Statement PredType] -> Expression PredType -> DsM (Expression PredType)
dsDo sts e = foldrM dsStmt e sts
dsStmt :: Statement PredType -> Expression PredType -> DsM (Expression PredType)
dsStmt (StmtExpr e1) e' =
return $ apply (prelBind_ (typeOf e1) (typeOf e')) [e1, e']
dsStmt (StmtBind t e1) e' = do
v <- freshVar "_#var" t
let func = Lambda [uncurry VariablePattern v] $
Case Rigid (uncurry mkVar v)
[ caseAlt NoPos t e'
, caseAlt NoPos (uncurry VariablePattern v)
(failedPatternMatch $ typeOf e')
]
return $ apply (prelBind (typeOf e1) (typeOf t) (typeOf e')) [e1, func]
where failedPatternMatch ty =
apply (prelFail ty)
[Literal predStringType $ String "Pattern match failed!"]
dsStmt (StmtDecl ds) e' = return $ Let ds e'
dsListComp :: Position -> Expression PredType -> [Statement PredType]
-> DsM (Expression PredType)
dsListComp p e [] =
dsExpr p (List (predType $ listType $ typeOf e) [e])
dsListComp p e (q:qs) = dsQual p q (ListCompr e qs)
dsQual :: Position -> Statement PredType -> Expression PredType
-> DsM (Expression PredType)
dsQual p (StmtExpr b) e =
dsExpr p (IfThenElse b e (List (predType $ typeOf e) []))
dsQual p (StmtDecl ds) e = dsExpr p (Let ds e)
dsQual p (StmtBind t l) e
| isVariablePattern t = dsExpr p (qualExpr t e l)
| otherwise = do
v <- freshVar "_#var" t
l' <- freshVar "_#var" e
dsExpr p (apply (prelFoldr (typeOf t) (typeOf e))
[foldFunct v l' e, List (predType $ typeOf e) [], l])
where
qualExpr v (ListCompr e1 []) l1
= apply (prelMap (typeOf v) (typeOf e1)) [Lambda [v] e1, l1]
qualExpr v e1 l1
= apply (prelConcatMap (typeOf v) (elemType $ typeOf e1)) [Lambda [v] e1, l1]
foldFunct v l1 e1
= Lambda (map (uncurry VariablePattern) [v, l1])
(Case Rigid (uncurry mkVar v)
[ caseAlt p t (append e1 (uncurry mkVar l1))
, caseAlt p (uncurry VariablePattern v) (uncurry mkVar l1)])
append (ListCompr e1 []) l1 = apply (prelCons (typeOf e1)) [e1, l1]
append e1 l1 = apply (prelAppend (elemType $ typeOf e1)) [e1, l1]
prelCons ty = Constructor (predType $ consType ty) $ qConsId
dsList :: (b -> b -> b) -> b -> [b] -> b
dsList = foldr
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 :: PredType -> Literal
-> Either (Expression PredType) (Expression PredType)
dsLiteral pty (Char c) = Right $ Literal pty $ Char c
dsLiteral pty (Int i) = Right $ fixLiteral (unpredType pty)
where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
fixLiteral ty
| ty == intType = Literal pty $ Int i
| ty == floatType = Literal pty $ Float $ fromInteger i
| otherwise = Apply (prelFromInt $ unpredType pty) $
Literal predIntType $ Int i
dsLiteral pty f@(Float _) = Right $ fixLiteral (unpredType pty)
where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
fixLiteral ty
| ty == floatType = Literal pty f
| otherwise = Apply (prelFromFloat $ unpredType pty) $
Literal predFloatType f
dsLiteral pty (String cs) =
Left $ List pty $ map (Literal pty' . Char) cs
where pty' = predType $ elemType $ unpredType pty
negateLiteral :: Literal -> Literal
negateLiteral (Int i) = Int (i)
negateLiteral (Float f) = Float (f)
negateLiteral _ = internalError "Desugar.negateLiteral"
preludeFun :: [Type] -> Type -> String -> Expression PredType
preludeFun tys ty = Variable (predType $ foldr TypeArrow ty tys) . preludeIdent
preludeIdent :: String -> QualIdent
preludeIdent = qualifyWith preludeMIdent . mkIdent
prelBind :: Type -> Type -> Type -> Expression PredType
prelBind ma a mb = preludeFun [ma, TypeArrow a mb] mb ">>="
prelBind_ :: Type -> Type -> Expression PredType
prelBind_ ma mb = preludeFun [ma, mb] mb ">>"
prelFlip :: Type -> Type -> Type -> Expression PredType
prelFlip a b c = preludeFun [TypeArrow a (TypeArrow b c), b, a] c "flip"
prelFromInt :: Type -> Expression PredType
prelFromInt a = preludeFun [intType] a "fromInt"
prelFromFloat :: Type -> Expression PredType
prelFromFloat a = preludeFun [floatType] a "fromFloat"
prelEnumFrom :: Type -> Expression PredType
prelEnumFrom a = preludeFun [a] (listType a) "enumFrom"
prelEnumFromTo :: Type -> Expression PredType
prelEnumFromTo a = preludeFun [a, a] (listType a) "enumFromTo"
prelEnumFromThen :: Type -> Expression PredType
prelEnumFromThen a = preludeFun [a, a] (listType a) "enumFromThen"
prelEnumFromThenTo :: Type -> Expression PredType
prelEnumFromThenTo a = preludeFun [a, a, a] (listType a) "enumFromThenTo"
prelNegate :: Type -> Expression PredType
prelNegate a = preludeFun [a] a "negate"
prelFail :: Type -> Expression PredType
prelFail ma = preludeFun [stringType] ma "fail"
prelFailed :: Type -> Expression PredType
prelFailed a = preludeFun [] a "failed"
prelUnknown :: Type -> Expression PredType
prelUnknown a = preludeFun [] a "unknown"
prelMap :: Type -> Type -> Expression PredType
prelMap a b = preludeFun [TypeArrow a b, listType a] (listType b) "map"
prelFoldr :: Type -> Type -> Expression PredType
prelFoldr a b =
preludeFun [TypeArrow a (TypeArrow b b), b, listType a] b "foldr"
prelAppend :: Type -> Expression PredType
prelAppend a = preludeFun [listType a, listType a] (listType a) "++"
prelConcatMap :: Type -> Type -> Expression PredType
prelConcatMap a b =
preludeFun [TypeArrow a (listType b), listType a] (listType b) "concatMap"
(=:<=) :: Expression PredType -> Expression PredType -> Expression PredType
e1 =:<= e2 = apply (preludeFun [typeOf e1, typeOf e2] boolType "=:<=") [e1, e2]
(=:=) :: Expression PredType -> Expression PredType -> Expression PredType
e1 =:= e2 = apply (preludeFun [typeOf e1, typeOf e2] boolType "=:=") [e1, e2]
(&>) :: Expression PredType -> Expression PredType -> Expression PredType
e1 &> e2 = apply (preludeFun [boolType, typeOf e2] (typeOf e2) "cond") [e1, e2]
(&) :: Expression PredType -> Expression PredType -> Expression PredType
e1 & e2 = apply (preludeFun [boolType, boolType] boolType "&") [e1, e2]
truePat :: Pattern PredType
truePat = ConstructorPattern predBoolType qTrueId []
falsePat :: Pattern PredType
falsePat = ConstructorPattern predBoolType qFalseId []
conType :: QualIdent -> ValueEnv -> ([Ident], ExistTypeScheme)
conType c vEnv = case qualLookupValue c vEnv of
[DataConstructor _ _ ls ty] -> (ls , ty)
[NewtypeConstructor _ l ty] -> ([l], ty)
_ -> internalError $ "Desguar.conType: " ++ show c
varType :: QualIdent -> ValueEnv -> TypeScheme
varType v vEnv = case qualLookupValue v vEnv of
Value _ _ _ tySc : _ -> tySc
Label _ _ tySc : _ -> tySc
_ -> internalError $ "Desugar.varType: " ++ show v
elemType :: Type -> Type
elemType (TypeApply (TypeConstructor tc) ty) | tc == qListId = ty
elemType ty = internalError $ "Base.Types.elemType " ++ show ty
applyConstr :: PredType -> QualIdent -> [Type] -> [Expression PredType]
-> Expression PredType
applyConstr pty c tys =
apply (Constructor (predType (foldr TypeArrow (unpredType pty) tys)) c)
instType :: ExistTypeScheme -> Type
instType (ForAllExist _ _ pty) = inst $ unpredType pty
where inst (TypeConstructor tc) = TypeConstructor tc
inst (TypeApply ty1 ty2) = TypeApply (inst ty1) (inst ty2)
inst (TypeVariable tv) = TypeVariable (1 tv)
inst (TypeArrow ty1 ty2) = TypeArrow (inst ty1) (inst ty2)
inst ty = ty
constructors :: QualIdent -> DsM [DataConstr]
constructors tc = getTyConsEnv >>= \tcEnv -> return $
case qualLookupTypeInfo tc tcEnv of
[DataType _ _ cs] -> cs
[RenamingType _ _ nc] -> [nc]
_ ->
internalError $ "Transformations.Desugar.constructors: " ++ show tc
argumentTypes :: Type -> QualIdent -> ValueEnv -> ([QualIdent], [Type])
argumentTypes ty c vEnv =
(map (qualifyLike c) ls, map (subst (matchType ty0 ty idSubst)) tys)
where (ls, ForAllExist _ _ (PredType _ ty')) = conType c vEnv
(tys, ty0) = arrowUnapply ty'