added positivity check

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)

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

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)

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