diff --git a/bad.hm b/bad.hm new file mode 100644 index 0000000..9e1c149 --- /dev/null +++ b/bad.hm @@ -0,0 +1,21 @@ +type bot + +type top + | u : top + +type bad + | b : (top → bad → bot) → bad + +-- TArr (TArr top (TArr bad bot)) bad + +getBad : bad → (top → bad → bot) + := rec[bad] (λx. x) + +uBad : top → bad → bot + := λu b. (getBad b) u b + +bBad : bad → bot + := λb. (getBad b) u b + +veryBad : bot + := bBad (b uBad) diff --git a/src/PostProcess.hs b/src/PostProcess.hs index b1701e5..c23dad5 100644 --- a/src/PostProcess.hs +++ b/src/PostProcess.hs @@ -46,29 +46,46 @@ defToTL (H.TypeDef p t ds) = do let (Id s) = i monoT <- declTo2pl <~> ds + let monoTs = map snd monoT let env = M.fromList (map (\(i,m) -> (i, Mono m)) monoT) -- check that all constructors construct correct type - mapM_ (guard (throwError (InvalidConstructor)) . constructs i . snd) monoT + mapM_ (guard (throwError (InvalidConstructor)) . constructs i) monoTs -- check that there are no unbound variables guard (throwError (Unimplemented "Type parameters")) (free env == S.empty) + -- dissallow contradictory types + mapM_ (guard (throwError (PositivityCheck i)) . positivityCheck i) monoTs + -- add recursor to env tv <- lift fresh let replace = \case { + TArr l@TArr{} r -> TArr l (replace r) ; TArr l r -> TArr (replace l) (replace r) ; TCon i' -> if i' == i then tv else TCon i' ; TVar i' -> TVar i' ; } - recType <- lift . generalize . foldr TArr (TCon i `TArr` tv) . map (replace . snd) $ monoT + recType <- lift . generalize . foldr TArr (TCon i `TArr` tv) . map replace $ monoTs let env' = M.insert (Id ("rec[" <> s <> "]")) recType env pure (TypeDef p i [] env') +positivityCheck :: Id -> MonoT -> Bool +positivityCheck i = \case + TArr l@TArr{} r -> not (parameterIn i l) + TArr l r -> positivityCheck i l && positivityCheck i r + _ -> True + +parameterIn :: Id -> MonoT -> Bool +parameterIn i = \case + TArr (TCon i') r -> i' == i || parameterIn i r + TArr l r -> parameterIn i l || parameterIn i r + _ -> False + typeSigToIdParams :: H.TypeSig -> Process (Id, [Id]) typeSigToIdParams = \case diff --git a/src/Pretty.hs b/src/Pretty.hs index b1d2f57..6b7e638 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -54,4 +54,5 @@ instance Pretty TypeError where UnboundVariable Nothing (Id i) -> "UnboundVariable: '" <> i <> "'" AlreadyDefined (Just (l,c)) (Id i) -> "'" <> i <> "' already defined at " <> T.pack (show l) <> ":" <> T.pack (show c) AlreadyDefined Nothing (Id i) -> "'" <> i <> "' already defined" + PositivityCheck (Id i) -> "PositivityCheck failed for type '" <> i <> "'" t -> T.pack (show t) diff --git a/src/Type.hs b/src/Type.hs index 129511d..606e8f5 100644 --- a/src/Type.hs +++ b/src/Type.hs @@ -125,6 +125,7 @@ data TypeError | ArityMismatch | AlreadyDefined Pos Id | MutuallyRecursive (Set Id) + | PositivityCheck Id deriving Show type TypeEnv = Map Id PolyT