Permalink
Browse files

polymorphic kind inference off, turn on (off) with LANGUAGE pragma (N…

…o)PolyKinds
  • Loading branch information...
1 parent b733f30 commit 3f09d1943b988bf17f05f5293899a4102a010928 @atzedijkstra atzedijkstra committed Sep 19, 2012
@@ -41,6 +41,10 @@ data Pragma
| Pragma_GenericDeriving -- turn on generic deriving (default)
| Pragma_NoBangPatterns -- turn off bang patterns
| Pragma_BangPatterns -- turn on bang patterns (default)
+ | Pragma_NoPolyKinds -- turn off polymorphic kinds (default)
+ | Pragma_PolyKinds -- turn on
+ | Pragma_NoOverloadedStrings -- turn off overloaded strings (default)
+ | Pragma_OverloadedStrings -- turn on
| Pragma_ExtensibleRecords -- turn on extensible records
| Pragma_Fusion -- turn on fusion syntax
| Pragma_OptionsUHC -- commandline options
@@ -69,6 +73,10 @@ allSimplePragmaMp
, Pragma_NoGenericDeriving
, Pragma_BangPatterns
, Pragma_NoBangPatterns
+ , Pragma_NoPolyKinds
+ , Pragma_PolyKinds
+ , Pragma_NoOverloadedStrings
+ , Pragma_OverloadedStrings
, Pragma_ExtensibleRecords
, Pragma_Fusion
]
@@ -120,6 +128,10 @@ instance Serialize Pragma where
sput (Pragma_NoBangPatterns ) = sputWord8 8
sput (Pragma_BangPatterns ) = sputWord8 9
sput (Pragma_OptionsUHC a ) = sputWord8 10 >> sput a
+ sput (Pragma_NoPolyKinds ) = sputWord8 11
+ sput (Pragma_PolyKinds ) = sputWord8 12
+ sput (Pragma_NoOverloadedStrings ) = sputWord8 13
+ sput (Pragma_OverloadedStrings ) = sputWord8 14
sget = do t <- sgetWord8
case t of
0 -> return Pragma_NoImplicitPrelude
@@ -135,6 +147,10 @@ instance Serialize Pragma where
8 -> return Pragma_NoBangPatterns
9 -> return Pragma_BangPatterns
10 -> liftM Pragma_OptionsUHC sget
+ 11 -> return Pragma_NoPolyKinds
+ 12 -> return Pragma_PolyKinds
+ 13 -> return Pragma_NoOverloadedStrings
+ 14 -> return Pragma_OverloadedStrings
%%]
View
@@ -409,7 +409,7 @@ SEM Expr
. gKiTvS = @tyKiUpdFreeTvarS
%%]]
. lQuTyGam = @tyGam_l_extra
- . lQuTyKiGam_qu = tyKiGamQuantify @gKiTvS @lSubsTyKiGam
+ . lQuTyKiGam_qu = tyKiGamQuantify @lhs.opts @gKiTvS @lSubsTyKiGam
. lQuTyKiGam_ex = tyKiGamInst1Exists @lUniq3 @lQuTyKiGam_qu
. lQuTyKiGam = @lQuTyKiGam_ex_extra
. lQuTyKiGam_ex_extra = gamUnion @extraTyKiGam @lQuTyKiGam_ex
@@ -437,7 +437,7 @@ SEM Expr
%%[(8 hmtyinfer)
SEM Expr
| Let loc . (lQuTyKiGam_qu,quTyKiVarMp, cycTyKiVarMp_l)
- := tyKiGamQuantifyWithVarMp @decls.kiVarMp @gKiTvS @tyKiGam_l_
+ := tyKiGamQuantifyWithVarMp @lhs.opts @decls.kiVarMp @gKiTvS @tyKiGam_l_
. bodyTyKiVarMp1 = @quTyKiVarMp `varUpd` @decls.kiVarMp
. (lQuTyKiGam_ex,exTyKiVarMp2)
:= tyKiGamInst1ExistsWithVarMp @bodyTyKiVarMp1 @lUniq3 @lQuTyKiGam_qu
@@ -679,7 +679,7 @@ SEM Decl
%%[(6 hmtyinfer)
SEM Decl
- | KiSig loc . sigKi = tyKiQuantify (const False) @kiExpr.ki
+ | KiSig loc . sigKi = tyKiQuantify True (const False) @kiExpr.ki
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -5,7 +5,7 @@
%%[(3 hmtyinfer) module {%{EH}Gam.Quantify}
%%]
-%%[(3 hmtyinfer) hs import ({%{EH}Base.Common})
+%%[(3 hmtyinfer) hs import ({%{EH}Base.Common}, {%{EH}Opts.Base})
%%]
%%[(3 hmtyinfer) hs import ({%{EH}Ty})
%%]
@@ -86,16 +86,16 @@ valGamQuantifyWithVarMp doQuant tyKiGam tvKiVarMp gamVarMp globTvS prL valGam
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%[(6 hmtyinfer || hmtyast).tyKiGamQuantify export(tyKiGamQuantify)
-tyKiGamQuantify :: TyVarIdS -> TyKiGam -> TyKiGam
-tyKiGamQuantify globTvS
- = gamMap (\(n,k) -> (n,k {tkgiKi = tyKiQuantify (`Set.member` globTvS) (tkgiKi k)}))
+tyKiGamQuantify :: EHCOpts -> TyVarIdS -> TyKiGam -> TyKiGam
+tyKiGamQuantify opts globTvS
+ = gamMap (\(n,k) -> (n,k {tkgiKi = tyKiQuantify (ehcOptPolyKinds opts) (`Set.member` globTvS) (tkgiKi k)}))
%%]
%%[(8 hmtyinfer || hmtyast).tyKiGamQuantifyWithVarMp -6.tyKiGamQuantify export(tyKiGamQuantifyWithVarMp)
-tyKiGamQuantifyWithVarMp :: {- TyKiGam -> VarMp -> -} VarMp -> TyVarIdS -> TyKiGam -> (TyKiGam,VarMp,VarMp)
-tyKiGamQuantifyWithVarMp {- tyKiGam tvKiVarMp -} gamVarMp globTvS gam
+tyKiGamQuantifyWithVarMp :: EHCOpts -> VarMp -> TyVarIdS -> TyKiGam -> (TyKiGam,VarMp,VarMp)
+tyKiGamQuantifyWithVarMp opts {- tyKiGam tvKiVarMp -} gamVarMp globTvS gam
= tyKiGamDoWithVarMp
- (\_ (t,tyCycMp) m cycMp -> (tyKiQuantify {- (tvarKi tyKiGam tvKiVarMp gamVarMp) -} (`Set.member` globTvS) t,m,tyCycMp `varUpd` cycMp))
+ (\_ (t,tyCycMp) m cycMp -> (tyKiQuantify (ehcOptPolyKinds opts) {- (tvarKi tyKiGam tvKiVarMp gamVarMp) -} (`Set.member` globTvS) t,m,tyCycMp `varUpd` cycMp))
gamVarMp emptyVarMp gam
%%]
View
@@ -73,15 +73,19 @@ ehcOptUpdateWithPragmas pragmas opts
= foldr (\p om@(o,modf) -> maybe om (\o -> (o,True)) $ upd p o) (opts,False) (Set.toList pragmas)
where upd pragma opts
= case pragma of
- Pragma_NoGenericDeriving -> Just $ opts { ehcOptGenGenerics = False }
- Pragma_GenericDeriving -> Just $ opts { ehcOptGenGenerics = True }
- Pragma_NoBangPatterns -> Just $ opts { ehcOptBangPatterns = False }
- Pragma_BangPatterns -> Just $ opts { ehcOptBangPatterns = True }
- Pragma_ExtensibleRecords -> Just $ opts { ehcOptExtensibleRecords = True }
- Pragma_Fusion -> Just $ opts { ehcOptFusion = True }
- Pragma_OptionsUHC o -> fmap (\o -> o {ehcOptCmdLineOptsDoneViaPragma = True}) mo
- where (mo,_,_) = ehcCmdLineOptsApply (words o) opts
- _ -> Nothing
+ Pragma_NoGenericDeriving -> Just $ opts { ehcOptGenGenerics = False }
+ Pragma_GenericDeriving -> Just $ opts { ehcOptGenGenerics = True }
+ Pragma_NoBangPatterns -> Just $ opts { ehcOptBangPatterns = False }
+ Pragma_BangPatterns -> Just $ opts { ehcOptBangPatterns = True }
+ Pragma_NoOverloadedStrings -> Just $ opts { ehcOptOverloadedStrings = False }
+ Pragma_OverloadedStrings -> Just $ opts { ehcOptOverloadedStrings = True }
+ Pragma_NoPolyKinds -> Just $ opts { ehcOptPolyKinds = False }
+ Pragma_PolyKinds -> Just $ opts { ehcOptPolyKinds = True }
+ Pragma_ExtensibleRecords -> Just $ opts { ehcOptExtensibleRecords = True }
+ Pragma_Fusion -> Just $ opts { ehcOptFusion = True }
+ Pragma_OptionsUHC o -> fmap (\o -> o {ehcOptCmdLineOptsDoneViaPragma = True}) mo
+ where (mo,_,_) = ehcCmdLineOptsApply (words o) opts
+ _ -> Nothing
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
View
@@ -147,6 +147,9 @@ data EHCOpts
, ehcOptImmQuit :: Maybe ImmediateQuitOption
, ehcOptDebug :: Bool -- debug info
, ehcStopAtPoint :: CompilePoint -- stop at (after) compile phase
+%%[[6
+ , ehcOptPolyKinds :: Bool -- allow kind polymorphism
+%%]]
%%[[7
, ehcOptExtensibleRecords
:: Bool
@@ -241,7 +244,8 @@ data EHCOpts
, ehcOptCPP :: Bool -- do preprocess with C preprecessor CPP
, ehcOptUseAssumePrelude -- use & assume presence of prelude
:: Bool
- , ehcOptPackageSearchFilter :: [PackageSearchFilter] -- description of what to expose from package database
+ , ehcOptPackageSearchFilter
+ :: [PackageSearchFilter] -- description of what to expose from package database
, ehcOptOutputDir :: Maybe String -- where to put output, instead of same dir as input file
, ehcOptKeepIntermediateFiles
:: Bool -- keep intermediate files
@@ -251,6 +255,8 @@ data EHCOpts
, ehcOptCmdLineOpts :: CmdLineOpts -- options from the commandline and pragma for such options
, ehcOptCmdLineOptsDoneViaPragma
:: Bool -- options via OPTIONS_UHC pragma have been set
+ , ehcOptOverloadedStrings
+ :: Bool -- allow overloaded strings
%%]]
}
%%]
@@ -285,6 +291,11 @@ emptyEHCOpts
, ehcOptImmQuit = Nothing
, ehcOptDebug = False
, ehcStopAtPoint = CompilePoint_All
+%%[[6
+ , ehcOptPolyKinds = True
+%%][99
+ , ehcOptPolyKinds = False
+%%]]
%%[[7
, ehcOptExtensibleRecords= True
%%][99
@@ -393,6 +404,7 @@ emptyEHCOpts
, ehcOptCmdLineOpts = []
, ehcOptCmdLineOptsDoneViaPragma
= False
+ , ehcOptOverloadedStrings= False
%%]]
}
%%]
@@ -89,13 +89,19 @@ tyQuantifyOuter tvKi tvIsBound ty
%%]
%%[(6 hmtyinfer || hmtyast) -3.valTyQuantify hs export(tyKiQuantify,valTyQuantify)
-tyKiQuantify :: TvIsBound -> Ty -> Ty
-tyKiQuantify tvIsBound ty -- = tyQuantify' tvIsBound tyQu_Forall {- tyQu_KiForall -} ty
+-- | Quantify kind, i.e. add universal quantifier for free tvars when kind polymorphism is allowed, otherwise just *
+tyKiQuantify
+ :: Bool -- ^ kind polymorphism on (for inference steered by PolyKinds pragma)
+ -> TvIsBound
+ -> Ty
+ -> Ty
+tyKiQuantify polyKinds tvIsBound ty -- = tyQuantify' tvIsBound tyQu_Forall {- tyQu_KiForall -} ty
= tqoTy $ tyQuantifyWithOpts opts ty
where opts = defaultTyQuOpts
- { tqoptAllowInnerQuant = False
- , tqoptTvIsBound = tvIsBound
- , tqoptBaseQuant = tyQu_Forall
+ { tqoptAllowInnerQuant = False
+ , tqoptTvIsBound = tvIsBound
+ , tqoptBaseQuant = tyQu_Forall
+ , tqoptQuantVarDefaultsTo = if polyKinds then Nothing else Just kiStar
}
valTyQuantify :: (TyVarId -> Ty) -> TvIsBound -> Ty -> Ty
@@ -129,12 +135,13 @@ tyQuantify' tvIsBound baseQuant ty
data TyQuOpts
= TyQuOpts
{ tqoptTvIsBound :: TvIsBound
+ , tqoptQuantVarDefaultsTo :: !(Maybe Ty) -- ^ if provided, not quantification takes place but var defaults to this
%%[[4
- , tqoptAllowInnerQuant :: Bool
+ , tqoptAllowInnerQuant :: !Bool
%%]]
%%[[6
- , tqoptBaseQuant :: TyQu
- , tqoptTvL1 :: TyVarId -> Ty -- mapping of tvar to 1 higher metalevel ty (i.e. kind)
+ , tqoptBaseQuant :: !TyQu
+ , tqoptTvL1 :: TyVarId -> Ty -- ^ mapping of tvar to 1 higher metalevel ty (i.e. kind)
%%]]
%%[[9
, tqoptQuRanks :: [Int]
@@ -145,6 +152,7 @@ defaultTyQuOpts :: TyQuOpts
defaultTyQuOpts
= TyQuOpts
(const False)
+ Nothing
%%[[4
True
%%]]
@@ -363,17 +371,33 @@ tvarsToQuantL1 boundablesL tvIsBound
%%]
%%[(4 hmtyinfer || hmtyast).tvarsToQuant hs
-tvarsToQuant :: TyQuOpts -> Bool -> TvCatMp -> (TyVarId -> Bool) -> TvLevIsBound -> TyVarIdS -> (TyVarIdsToBind,TyVarIdsToBind,TyVarIdsToBind,TvLevIsBound)
+-- | Compute bindable tvars
+tvarsToQuant
+ :: TyQuOpts
+ -> Bool
+ -> TvCatMp
+ -> (TyVarId -> Bool)
+ -> TvLevIsBound -- ^ 'is already bound?'
+ -> TyVarIdS
+ -> ( TyVarIdsToBind -- ^ to bind universal, on this level
+ , TyVarIdsToBind -- ^ to bind existential
+ , TyVarIdsToBind -- ^ to bind universal, 1 level higher
+ , TvLevIsBound -- ^ updated 'is already bound?'
+ , VarMp -- ^ the tvars which are defaulted
+ )
tvarsToQuant opts isQuLoc _ mayQuFx tvIsBound tvS
= if isQuLoc
then let boundablesS = tvNotBound 0 tvIsBound tvS
%%[[4
boundablesL = Set.toList boundablesS
tvIsBound' = tvBoundAddS 0 boundablesS tvIsBound
%%][6
- boundablesL = [ (v,{- trm "tvarsToQuant" (\k -> v >|< "::" >|< k) $ -} tqoptTvL1 opts v) | v <- Set.toList boundablesS ]
- (boundablesL1L,_,tvIsBound') = tvarsToQuantL1 boundablesL (tvBoundAddS 0 boundablesS tvIsBound)
- -- tvIsBound' = tvBoundAddS (boundablesS `Set.union` boundablesL1S) tvIsBound
+ (boundablesL,boundablesL1L,tvIsBound',defaultedVarMp)
+ | isJust mbDf = ([] , [] , tvIsBound, assocTyLToVarMp [ (v,df) | (v,_) <- boundablesL ])
+ | otherwise = (boundablesL, b1L, isb , emptyVarMp )
+ where mbDf@(~(Just df)) = tqoptQuantVarDefaultsTo opts
+ (b1L,_,isb) = tvarsToQuantL1 boundablesL (tvBoundAddS 0 boundablesS tvIsBound)
+ boundablesL = [ (v, tqoptTvL1 opts v) | v <- Set.toList boundablesS ]
%%]]
in ( boundablesL
, []
@@ -383,8 +407,9 @@ tvarsToQuant opts isQuLoc _ mayQuFx tvIsBound tvS
, boundablesL1L
%%]]
, tvIsBound'
+ , defaultedVarMp
)
- else ([],[],[],tvIsBound)
+ else ([],[],[],tvIsBound,emptyVarMp)
%%]
%%[(6_4 hmtyinfer || hmtyast).tvarsToQuant -4.tvarsToQuant hs
@@ -417,18 +442,18 @@ tvMayQuFx qu fxTvM isQuFxLoc tv
ATTR AllTy [ tvIsBound: {TvLevIsBound} | | ]
SEM TyAGItf
- | AGItf loc . (qBndTvs,qBndExTvs,qBndL1Tvs,tvIsBound)
+ | AGItf loc . (qBndTvs,qBndExTvs,qBndL1Tvs,tvIsBound,defaultedVarMpNew)
= tvarsToQuant @lhs.opts True @fxTvM
(const False)
(tvIsBound2L0 $ tqoptTvIsBound @lhs.opts) @qHereTvS
SEM Ty
- | App Var loc . (qBndTvs,qBndExTvs,qBndL1Tvs,tvIsBound)
+ | App Var loc . (qBndTvs,qBndExTvs,qBndL1Tvs,tvIsBound,defaultedVarMpNew)
= tvarsToQuant @lhs.opts @isQuLoc @lhs.fxTvM
(tvMayQuFx @hereQu @lhs.fxTvM @isQuFxLoc)
@lhs.tvIsBound @qHereTvS
| TBind loc . tvIsBoundQu = tvBoundAddS 0 @introTVarS @lhs.tvIsBound
- . (qBndTvs,qBndExTvs,qBndL1TvsOther,tvIsBound)
+ . (qBndTvs,qBndExTvs,qBndL1TvsOther,tvIsBound,defaultedVarMpNew)
= tvarsToQuant @lhs.opts @isQuLoc @lhs.fxTvM
(tvMayQuFx @hereQu @lhs.fxTvM @isQuFxLoc)
@tvIsBoundQu @qHereTvS
@@ -445,13 +470,13 @@ SEM Ty
%%[(9 hmtyinfer || hmtyast)
SEM Ty
- | App Var loc . (qBndTvs,qBndExTvs,qBndL1Tvs,tvIsBound)
+ | App Var loc . (qBndTvs,qBndExTvs,qBndL1Tvs,tvIsBound,defaultedVarMpNew)
:= tvarsToQuant @lhs.opts @isQuLoc @lhs.fxTvM (tvMayQuFx @hereQu @lhs.fxTvM @isQuFxLoc) @lhs.tvIsBound @qHereTvS
%%]
%%[(9 hmtyinfer || hmtyast)
SEM Ty
- | Pred loc . (qBndTvs,qBndExTvs,qBndL1Tvs,tvIsBound)
+ | Pred loc . (qBndTvs,qBndExTvs,qBndL1Tvs,tvIsBound,defaultedVarMpNew)
= tvarsToQuant @lhs.opts @isQuLoc @lhs.fxTvM (const False) @lhs.tvIsBound @qHereTvS
%%]
@@ -461,6 +486,24 @@ SEM Ty
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% Mapping for defaulting tyvars
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%[(4 hmtyinfer || hmtyast)
+ATTR AllTy [ defaultedVarMp: VarMp | | ]
+
+SEM TyAGItf
+ | AGItf loc . defaultedVarMp = @defaultedVarMpNew
+
+SEM Ty
+ | App Var TBind
+%%[[9
+ Pred
+%%]]
+ loc . defaultedVarMp = @defaultedVarMpNew `varUpd` @lhs.defaultedVarMp
+%%]
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Which quantifier to use for quantification
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -520,7 +563,7 @@ SEM TyAGItf
| AGItf loc . quTyBase = @ty.quTy
SEM Ty
- | Var loc . quTyBase = Ty_Var @tv @categ.quTy
+ | Var loc . quTyBase = maybe (Ty_Var @tv @categ.quTy) id $ varmpTyLookup @tv @lhs.defaultedVarMp
| App loc . quTyBase = Ty_App @func.quTy @arg.quTy
| TBind loc . quTyBase =
%%[[4
@@ -3,6 +3,8 @@
expected: error because U's kind is too general for Functor
---------------------------------------------------------------------------------------- -}
+{-# LANGUAGE PolyKinds #-}
+
module KindSig2 where
-- the signature would make U acceptable for Functor
@@ -0,0 +1,18 @@
+{- ----------------------------------------------------------------------------------------
+ what : poly kind inference
+ expected: ok
+---------------------------------------------------------------------------------------- -}
+
+{-# LANGUAGE PolyKinds #-}
+
+module PolyKinds1 where
+
+data Proxy t = Proxy
+
+class Foo t where
+ bar :: Proxy t -> Int
+
+instance Foo Int where bar _ = 0
+instance Foo [] where bar _ = 0
+
+main = return ()
@@ -0,0 +1,18 @@
+{- ----------------------------------------------------------------------------------------
+ what : poly kind inference
+ expected: not ok, because of NoPolyKinds
+---------------------------------------------------------------------------------------- -}
+
+{-# LANGUAGE NoPolyKinds #-}
+
+module PolyKinds2 where
+
+data Proxy t = Proxy
+
+class Foo t where
+ bar :: Proxy t -> Int
+
+instance Foo Int where bar _ = 0
+instance Foo [] where bar _ = 0
+
+main = return ()
Oops, something went wrong.

0 comments on commit 3f09d19

Please sign in to comment.