├── .gitignore ├── ChangeLog.md ├── LICENSE ├── Setup.hs ├── cccc.cabal ├── src ├── CCC.hs ├── Compiler.hs ├── Evaluation.hs ├── Main.hs ├── StdLib.hs ├── TypeChecking.hs ├── Types.hs └── Utils.hs ├── stack.yaml └── test ├── CCCSpec.hs ├── EvalSpec.hs ├── Main.hs └── TypeCheckingSpec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/isovector/cccc/57497046e7bf6170dfdb4964da6840001d46c91f/ChangeLog.md -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/isovector/cccc/57497046e7bf6170dfdb4964da6840001d46c91f/LICENSE -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cccc.cabal: -------------------------------------------------------------------------------- 1 | name: cccc 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Sandy Maguire 8 | maintainer: sandy@sandymaguire.me 9 | -- copyright: 10 | category: Language 11 | build-type: Simple 12 | extra-source-files: ChangeLog.md 13 | cabal-version: >=1.10 14 | 15 | library 16 | exposed-modules: TypeChecking, Types, CCC, Evaluation, StdLib, Utils, Compiler 17 | -- other-modules: 18 | -- other-extensions: 19 | build-depends: base >=4.9 && <4.10, base-prelude, containers, lens, mtl, transformers, recursion-schemes, bound, deriving-compat 20 | hs-source-dirs: src 21 | default-language: Haskell2010 22 | 23 | Test-Suite tests 24 | type: exitcode-stdio-1.0 25 | default-language: Haskell2010 26 | other-modules: TypeCheckingSpec, CCCSpec, EvalSpec 27 | hs-Source-Dirs: test 28 | main-is: Main.hs 29 | build-depends: base >=4.9 && <4.10, base-prelude, containers, lens, mtl, transformers, hspec, cccc 30 | -------------------------------------------------------------------------------- /src/CCC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | module CCC where 5 | 6 | import Bound 7 | import Control.Arrow ((&&&)) 8 | import Data.Bool (bool) 9 | import Data.Monoid ((<>)) 10 | import TypeChecking 11 | import Types 12 | import Utils 13 | 14 | 15 | fork :: (a -> b) -> (a -> c) -> (a -> (b, c)) 16 | fork = (&&&) 17 | 18 | apply :: (a -> b, a) -> b 19 | apply = uncurry ($) 20 | 21 | 22 | simplify :: Exp VName -> Exp VName 23 | simplify ("." :@ "apply" :@ ("fork" :@ ("curry" :@ h) :@ g)) = 24 | simplify $ "." :@ h :@ ("fork" :@ "id" :@ g) 25 | simplify (V n) = V n 26 | simplify (LCon c) = LCon c 27 | simplify (a :@ b) = simplify a :@ simplify b 28 | simplify _ = error "simplify can only be done on pointfree exps" 29 | 30 | 31 | toCCC :: Exp VName -> Exp VName 32 | toCCC (Lam n x) = 33 | case unscope x of 34 | V (B ()) -> "id" 35 | V (F (V a)) -> 36 | (case a of 37 | -- TODO(sandy): more generally we should look at the SymTable and see 38 | -- if there is a categorical context in order to return id here 39 | "id" -> id 40 | "," -> id 41 | "fst" -> id 42 | "snd" -> id 43 | "inr" -> id 44 | "inl" -> id 45 | "." -> id 46 | _ -> \z -> ("." :@ z :@ "shouldInline") 47 | ) "const" :@ V a 48 | V (F _) -> error "this should never be hit" 49 | z | Just (c, as) <- unravel z 50 | -> "const" :@ (foldl (\a b -> a :@ anonLam b) (LCon c) as) 51 | u :@ v -> 52 | foldl1 (:@) 53 | [ "." 54 | , "apply" 55 | , foldl1 (:@) 56 | [ "fork" 57 | , anonLam u 58 | , anonLam v 59 | ] 60 | ] 61 | Lam n2 y -> 62 | let name = VName $ unVName n <> "+" <> unVName n2 63 | in 64 | ( case unscope y of 65 | V (F _) -> ("curry" :@) 66 | _ -> id 67 | ) . toCCC 68 | . lam name 69 | . unsafeInst1 ("snd" :@ V name) 70 | . instantiate1 ("fst" :@ V name) 71 | $ x 72 | LInt i -> "const" :@ LInt i 73 | -- TODO(sandy): is this right? it discards info 74 | Assert a _ -> anonLam a 75 | Let _ b e -> anonLam $ instantiate1 b e 76 | where 77 | anonLam = toCCC . Lam n . Scope 78 | -- eta abstract a point-free function 79 | toCCC z = toCCC $ lam "!!!!z" $ z :@ "!!!!z" 80 | 81 | 82 | unsafeInst1 :: Exp VName -> Exp VName -> Exp VName 83 | unsafeInst1 z (Lam _ x) = instantiate1 z x 84 | unsafeInst1 _ _ = error "unsafeInst1" 85 | 86 | -------------------------------------------------------------------------------- /src/Compiler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | module Compiler where 7 | 8 | import Control.Lens ((<&>)) 9 | import Control.Monad (join) 10 | import Data.Map (Map) 11 | import qualified Data.Map as M 12 | import Data.Monoid ((<>)) 13 | import Data.Traversable (for) 14 | import TypeChecking 15 | import Types 16 | import Utils 17 | 18 | 19 | getGDCBinding :: GenDataCon -> (VName, (Qual Type, Exp VName)) 20 | getGDCBinding gdc = (gdcName gdc, (gdcConType gdc, gdcCon gdc)) 21 | 22 | 23 | compile :: CompUnit -> TI (Map VName (Exp VName), (ClassEnv, SymTable VName)) 24 | compile cu = do 25 | -- build classes 26 | let classes = cuClasses cu 27 | allCGdcs = M.fromList 28 | . zip (fmap cName classes) 29 | $ fmap buildDictType classes 30 | cgdcs = fmap fst allCGdcs 31 | classMethods = M.fromList 32 | . join 33 | . M.elems 34 | $ fmap snd allCGdcs 35 | 36 | -- build instances + dicts 37 | let instances = cuInsts cu 38 | instDicts = 39 | instances <&> \c -> 40 | let cname = predCName . unqualType $ irQuals c 41 | in buildDict (cgdcs M.! cname) c 42 | 43 | -- build class env 44 | let cenv = ClassEnv 45 | . M.fromList 46 | $ instances <&> \i -> 47 | (unqualType $ irQuals i, () <$ i) 48 | 49 | -- build defs 50 | let allDefs = mconcat $ 51 | [ M.fromList . fmap getGDCBinding $ mconcat 52 | [ M.elems cgdcs 53 | , cuGDCs cu 54 | , fmap fst $ cuRecords cu 55 | ] 56 | , classMethods 57 | , M.fromList instDicts 58 | , cuDecls cu 59 | , M.fromList . join . fmap snd $ cuRecords cu 60 | ] 61 | 62 | -- build initial symbol table 63 | let sym = SymTable $ fmap (generalize (SymTable @VName mempty) . fst) allDefs 64 | 65 | defs <- for (fmap snd allDefs) $ \i -> do 66 | (_, e) <- typeInference cenv sym i 67 | pure e 68 | 69 | pure (defs, (cenv, sym)) 70 | 71 | -------------------------------------------------------------------------------- /src/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | module Evaluation where 7 | 8 | import Bound 9 | import Compiler 10 | import Control.Lens ((<&>)) 11 | import Control.Monad (join) 12 | import Data.Bool (bool) 13 | import Data.Map (Map) 14 | import qualified Data.Map as M 15 | import Data.Maybe (mapMaybe) 16 | import Data.Monoid ((<>)) 17 | import TypeChecking 18 | import Types 19 | import Utils 20 | 21 | 22 | extract :: Pat -> Exp VName -> Maybe [(VName, Exp VName)] 23 | extract (PVar i) a = pure $ pure (i, a) 24 | extract (PAs i p) a = (:) <$> pure (i, a) <*> extract p a 25 | extract PWildcard _ = pure [] 26 | extract (PCon c ps) a 27 | | Just (c', as) <- unravel a 28 | , c == c' = 29 | if length ps /= length as 30 | then error $ "bad number of pattern ctors to " <> show c 31 | else fmap join 32 | . traverse (uncurry extract) 33 | $ zip ps as 34 | extract (PCon _ _) _ = Nothing 35 | extract (PLit l) (Lit l') 36 | | l == l' = Just [] 37 | | otherwise = Nothing 38 | extract (PLit _) _ = Nothing 39 | 40 | 41 | 42 | whnf :: Map VName (Exp VName) -> Exp VName -> Exp VName 43 | whnf std a 44 | | Just (func, as) <- unravelNative a 45 | = case func of 46 | "eqInt" -> 47 | case fmap (whnf std) as of 48 | [LInt a1, LInt a2] -> bool "False" "True" $ a1 == a2 49 | _ -> "bad args to eqInt" 50 | 51 | "eqString" -> 52 | case fmap (whnf std) as of 53 | [LString a1, LString a2] -> bool "False" "True" $ a1 == a2 54 | _ -> "bad args to eqString" 55 | 56 | "error" -> 57 | case fmap (whnf std) as of 58 | [LString a1] -> error a1 59 | _ -> "bad args to error" 60 | 61 | _ -> error $ "unimplemented native " <> func 62 | 63 | whnf std (V name) = 64 | case M.lookup name std of 65 | Just x -> whnf std x 66 | Nothing -> error $ "variable '" <> show name <> "' not in scope" 67 | whnf _ z@(LCon _) = z 68 | whnf std (f :@ a) = 69 | case whnf std f of 70 | Lam _ b -> whnf std (instantiate1 a b) 71 | f' -> f' :@ a 72 | whnf _ z@(Lit _) = z 73 | whnf std (Let _ v e) = whnf std $ instantiate1 v e 74 | whnf std (Assert e _) = whnf std e 75 | whnf std (Case e ps) = 76 | let e' = whnf std e 77 | in whnf std $ head $ flip mapMaybe ps $ \(p, v) -> 78 | extract p e' <&> \(M.fromList -> vs) -> 79 | instantiate (vs M.!) v 80 | whnf _ z@(Lam _ _) = z 81 | 82 | 83 | eval 84 | :: Map VName (Exp VName) 85 | -> (ClassEnv, SymTable VName) 86 | -> Exp VName 87 | -> Exp VName 88 | eval std (cenv, sym) e = 89 | case runTI $ typeInference cenv sym e of 90 | Left err -> error $ "failed to compile:\n" <> err 91 | Right (_, e') -> whnf std e' 92 | 93 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = do 5 | putStrLn "hello" 6 | 7 | -------------------------------------------------------------------------------- /src/StdLib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# OPTIONS_GHC -Wall #-} 6 | 7 | module StdLib where 8 | 9 | import Compiler 10 | import Data.Bifunctor (first, second) 11 | import Data.Map (Map) 12 | import qualified Data.Map as M 13 | import Evaluation 14 | import TypeChecking 15 | import Types 16 | import Utils 17 | 18 | 19 | prelude :: Map VName (Exp VName) 20 | preludeEnv :: (ClassEnv, SymTable VName) 21 | Right (prelude, preludeEnv) = runTI $ compile preludeSource 22 | 23 | 24 | pattern CK3 :: String -> TName 25 | pattern CK3 str = TName str ((KStar :>> KStar :>> KStar) :>> KStar) 26 | 27 | pattern CK2 :: String -> TName 28 | pattern CK2 str = TName str ((KStar :>> KStar) :>> KStar) 29 | 30 | pattern CKArr :: String -> TName 31 | pattern CKArr str = TName str (KStar :>> KStar :>> KStar) 32 | 33 | pattern CK1 :: String -> TName 34 | pattern CK1 str = TName str (KStar :>> KStar) 35 | 36 | 37 | preludeSource :: CompUnit 38 | preludeSource = CompUnit 39 | { cuClasses = 40 | [ Class "a" (CK1 "Eq") 41 | $ M.fromList [("==", [] :=> "a" :-> "a" :-> TBool)] 42 | 43 | , let func = CK1 "f" 44 | in Class func (CK2 "Functor") 45 | $ M.fromList 46 | 47 | [("fmap", [] 48 | :=> ("a" :-> "b") :-> TVar func :@@ "a" :-> TVar func :@@ "b")] 49 | 50 | , Class (TName "k" K2) (CK3 "Category") $ M.fromList 51 | [ ( "." 52 | , [] :=> TCat "k" "b" "c" 53 | :-> TCat "k" "a" "b" 54 | :-> TCat "k" "a" "c" 55 | ) 56 | , ( "id" 57 | , [] :=> TCat "k" "a" "a" 58 | ) 59 | ] 60 | ] 61 | 62 | , cuInsts = 63 | [ InstRep ([] :=> IsInst (CK2 "Functor") (TCon $ CK1 "Maybe")) $ M.fromList 64 | [ ( "fmap" 65 | , lam "f" $ lam "ma" $ 66 | case_ "ma" 67 | [ (PCon "Just" ["a"], "Just" :@ ("f" :@ "a")) 68 | , (PCon "Nothing" [], "Nothing") 69 | ] 70 | ) 71 | ] 72 | 73 | , InstRep ([] :=> IsInst (CK2 "Functor") (TCon $ CK1 "List")) $ M.fromList 74 | [ ( "fmap" 75 | , lam "f" $ lam "la" $ 76 | case_ "la" 77 | [ ( PCon "Cons" ["a", "as"] 78 | , "Cons" :@ ("f" :@ "a") 79 | :@ ("fmap" :@ "f" :@ "as")) 80 | , (PCon "Nil" [], "Nil") 81 | ] 82 | ) 83 | ] 84 | 85 | , InstRep ([] :=> IsInst (CK2 "Functor") 86 | ((TCon $ CK3 "Coyoneda") :@@ TVar (CK1 "f")) ) $ M.fromList 87 | [ ( "fmap" 88 | , lam "f" $ lam "c" $ 89 | "Coyoneda" 90 | :@ ("." :@ "f" :@ ("coFn" :@ "c")) 91 | :@ ("coFm" :@ "c") 92 | ) 93 | ] 94 | 95 | , InstRep ([] :=> IsInst (CK1 "Eq") TBool) $ M.fromList 96 | [ ( "==" 97 | , lam "x" $ lam "y" $ 98 | case_ "x" 99 | [ ( PFalse 100 | , case_ "y" 101 | [ ( PFalse 102 | , "True" 103 | ) 104 | , ( PWildcard 105 | , "False" 106 | ) 107 | ] 108 | ) 109 | , ( PTrue 110 | , case_ "y" 111 | [ ( PTrue 112 | , "True" 113 | ) 114 | , ( PWildcard 115 | , "False" 116 | ) 117 | ] 118 | ) 119 | ]) 120 | ] 121 | 122 | , InstRep ([IsInst (CK1 "Eq") "a", IsInst (CK1 "Eq") "b"] 123 | :=> IsInst (CK1 "Eq") (TProd "a" "b")) 124 | $ M.fromList 125 | [ ( "==" 126 | , lam "x" $ lam "y" $ 127 | case_ (LProd "x" "y") 128 | [ ( PProd (PProd "l1" "r1") (PProd "l2" "r2") 129 | , "&&" :@ ("==" :@ "l1" :@ "l2") 130 | :@ ("==" :@ "r1" :@ "r2") 131 | ) 132 | ]) 133 | ] 134 | 135 | , InstRep ([IsInst (CK1 "Eq") "a", IsInst (CK1 "Eq") "b"] 136 | :=> IsInst (CK1 "Eq") (TSum "a" "b")) 137 | $ M.fromList 138 | [ ( "==" 139 | , lam "x" $ lam "y" $ 140 | case_ "x" 141 | [ ( PCon "Inl" ["x1"] 142 | , case_ "y" 143 | [ ( PCon "Inl" ["y1"] 144 | , "==" :@ "x1" :@ "y1" 145 | ) 146 | , ( PWildcard 147 | , "False" 148 | ) 149 | ] 150 | ) 151 | , ( PCon "Inr" ["x1"] 152 | , case_ "y" 153 | [ ( PCon "Inr" ["y1"] 154 | , "==" :@ "x1" :@ "y1" 155 | ) 156 | , ( PWildcard 157 | , "False" 158 | ) 159 | ] 160 | ) 161 | ]) 162 | ] 163 | 164 | , InstRep ([] :=> IsInst (CK1 "Eq") TUnit) 165 | $ M.fromList 166 | [ ( "==" 167 | , lam "x" $ lam "y" "True" 168 | ) 169 | ] 170 | 171 | , InstRep ([] :=> IsInst (CK1 "Eq") TInt) 172 | $ M.fromList 173 | [ ( "==" 174 | , lam "x" $ lam "y" $ 175 | Lit (LitNative "eqInt" $ TInt :-> TInt :-> TBool) 176 | :@ "x" :@ "y" 177 | ) 178 | ] 179 | 180 | , InstRep ([] :=> IsInst (CK1 "Eq") TString) 181 | $ M.fromList 182 | [ ( "==" 183 | , lam "x" $ lam "y" $ 184 | Lit (LitNative "eqString" $ TString :-> TString :-> TBool) 185 | :@ "x" :@ "y" 186 | ) 187 | ] 188 | 189 | , InstRep ([] :=> IsInst (CK3 "Category") TArrCon) $ M.fromList 190 | [ ( "id" 191 | , lam "x" "x" 192 | ) 193 | , ( "." 194 | , lam "f" $ lam "g" $ lam "x" $ "f" :@ ("g" :@ "x") 195 | ) 196 | ] 197 | 198 | ] 199 | 200 | , cuGDCs = 201 | [ buildDataCon "Inl" ["a"] . Just $ TSum "a" "b" 202 | , buildDataCon "Inr" ["b"] . Just $ TSum "a" "b" 203 | , buildDataCon "False" [] . Just $ TBool 204 | , buildDataCon "True" [] . Just $ TBool 205 | , buildDataCon "Unit" [] . Just $ TUnit 206 | , buildDataCon "Nothing" [] . Just $ 207 | TCon (TName "Maybe" $ KStar :>> KStar) :@@ "a" 208 | , buildDataCon "Just" ["a"] . Just $ 209 | TCon (TName "Maybe" $ KStar :>> KStar) :@@ "a" 210 | , buildDataCon "Nil" [] . Just $ 211 | TCon (TName "List" $ KStar :>> KStar) :@@ "a" 212 | , buildDataCon "Cons" ["a", TCon (TName "List" $ KStar :>> KStar) :@@ "a"] . Just $ 213 | TCon (TName "List" $ KStar :>> KStar) :@@ "a" 214 | ] 215 | 216 | , cuRecords = 217 | [ buildRecord "," [("fst", "a"), ("snd", "b")] Nothing 218 | 219 | , let f = TVar (TName "f" $ KStar :>> KStar) 220 | in buildRecord 221 | "Coyoneda" 222 | [ ("coFn", "b" :-> "a") 223 | , ("coFm", f :@@ "b") 224 | ] 225 | $ Just 226 | $ TCon (TName "Coyoneda" $ (KStar :>> KStar) :>> KStar :>> KStar) 227 | :@@ f 228 | :@@ "a" 229 | ] 230 | 231 | , cuDecls = M.fromList 232 | [ ( "undefined" 233 | , ( [] :=> "a" 234 | , "error" :@ LString "undefined" 235 | ) 236 | ) 237 | 238 | , ( "&&" 239 | , ( [] :=> TBool :-> TBool :-> TBool 240 | , lam "x" $ lam "y" $ case_ "x" 241 | [ (PTrue, "y") 242 | , (PWildcard, "False") 243 | ] 244 | ) 245 | ) 246 | 247 | , ( "swap" 248 | , ( [] :=> TProd "a" "b" :-> TProd "b" "a" 249 | , lam "z" $ LProd ("snd" :@ "z") ("fst" :@ "z") 250 | ) 251 | ) 252 | 253 | , ( "proj" 254 | , ( [] 255 | :=> ("a" :-> "c") 256 | :-> ("b" :-> "c") 257 | :-> TSum "a" "b" 258 | :-> "c" 259 | , lam "f" $ lam "g" $ lam "e" $ 260 | case_ "e" 261 | [ ( PCon "Inl" [PVar "x"], "f" :@ "x") 262 | , ( PCon "Inr" [PVar "y"], "g" :@ "y") 263 | ] 264 | ) 265 | ) 266 | 267 | , ( "const" 268 | , ( [CCat "k"] 269 | :=> "b" 270 | :-> TCat "k" "a" "b" 271 | , lam "x" $ lam "y" $ "x" 272 | ) 273 | ) 274 | 275 | , ("error" 276 | , ( [] :=> TString :-> "a" 277 | , lam "x" $ 278 | Lit (LitNative "error" $ TString :-> "a") 279 | :@ "x" 280 | ) 281 | ) 282 | 283 | , ( "liftCoyoneda" 284 | , ( [] :=> TK1 "f" "a" 285 | :-> TCon (CK3 "Coyoneda") 286 | :@@ TVar (TName "f" K1) 287 | :@@ "a" 288 | , "Coyoneda" :@ "id" 289 | ) 290 | ) 291 | 292 | , ( "lowerCoyoneda" 293 | , ( [IsInst (CK2 "Functor") (TVar $ CK1 "f") ] 294 | :=> TCon (CK3 "Coyoneda") :@@ (TVar $ CK1 "f") :@@ "a" 295 | :-> (TVar $ CK1 "f") :@@ "a" 296 | , lam "c" $ "fmap" :@ ("coFn" :@ "c") :@ ("coFm" :@ "c") 297 | ) 298 | ) 299 | 300 | , ( "head" 301 | , ( [] :=> TCon (CK1 "List") :@@ "a" 302 | :-> "a" 303 | , lam "c" $ case_ "c" [(PCon "Cons" ["a", PWildcard], "a")] 304 | ) 305 | ) 306 | 307 | ] 308 | } 309 | 310 | 311 | 312 | test'' :: Exp VName -> Either String ((Qual Type, Type), Exp VName) 313 | test'' = second (first (first normalizeType)) 314 | . runTI 315 | . uncurry typeInference preludeEnv 316 | 317 | 318 | test' :: Exp VName -> Either String (Qual Type) 319 | test' = fmap (fst . fst) . test'' 320 | 321 | 322 | test :: Exp VName -> IO () 323 | test x = 324 | case test'' x of 325 | Left e -> putStrLn e 326 | Right ((t, t'), e) -> do 327 | putStrLn $ show t 328 | putStrLn $ show t' 329 | putStrLn $ show e 330 | 331 | -------------------------------------------------------------------------------- /src/TypeChecking.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TupleSections #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | {-# OPTIONS_GHC -Wall #-} 8 | 9 | module TypeChecking where 10 | 11 | import Bound 12 | import Bound.Scope 13 | import Control.Applicative ((<|>)) 14 | import Control.Lens ((<&>), view, (%~), (<>~)) 15 | import Control.Monad.Reader 16 | import Control.Monad.State 17 | import Control.Monad.Trans.Except 18 | import Data.Bifunctor 19 | import Data.Bool (bool) 20 | import Data.Foldable (for_) 21 | import Data.List (nub, intercalate) 22 | import Data.Map (Map) 23 | import qualified Data.Map as M 24 | import Data.Monoid ((<>), First (..)) 25 | import qualified Data.Set as S 26 | import Data.Traversable (for) 27 | import Prelude hiding (exp) 28 | import Types 29 | import Utils 30 | 31 | 32 | type Placeholder = Reader (Pred -> Exp VName) 33 | 34 | 35 | unify :: Type -> Type -> TI () 36 | unify t1 t2 = do 37 | s <- view tiSubst <$> get 38 | s' <- mgu (sub s t1) (sub s t2) 39 | modify $ tiSubst <>~ s' 40 | pure () 41 | 42 | 43 | newVName :: String -> TI VName 44 | newVName f = do 45 | n <- view tiVNames <$> get 46 | modify $ tiVNames %~ (+1) 47 | pure $ VName $ f <> show n 48 | 49 | 50 | newTyVar :: Kind -> TI Type 51 | newTyVar k = do 52 | n <- view tiTNames <$> get 53 | modify $ tiTNames %~ (+1) 54 | pure . TVar . flip TFreshName k $ letters !! n 55 | 56 | 57 | freshInst 58 | :: VName 59 | -> Scheme 60 | -> TI (Qual Type, Placeholder (Exp VName)) 61 | freshInst n (Scheme vars t) = do 62 | nvars <- traverse newTyVar $ fmap tKind vars 63 | let subst = Subst $ M.fromList (zip vars nvars) 64 | t'@(qs :=> _) = sub subst t 65 | pure (t', liftPlaceholders n qs) 66 | 67 | 68 | liftPlaceholders 69 | :: VName 70 | -> [Pred] 71 | -> Placeholder (Exp VName) 72 | liftPlaceholders name ps = do 73 | f <- ask 74 | let dicts = fmap f ps 75 | pure $ case length dicts of 76 | 0 -> V name 77 | _ -> foldl (:@) (V name) dicts 78 | 79 | 80 | mgu :: Type -> Type -> TI Subst 81 | mgu (l :@@ r) (l' :@@ r') = do 82 | s1 <- mgu l l' 83 | s2 <- mgu (sub s1 r) (sub s1 r') 84 | pure $ s1 <> s2 85 | mgu (TCon a) (TCon b) 86 | | a == b = pure mempty 87 | mgu (TVar u) t = varBind u t 88 | mgu t (TVar u) = varBind u t 89 | mgu t1 t2 = throwE $ 90 | mconcat 91 | [ "types don't unify: '" 92 | , show t1 93 | , "' vs '" 94 | , show t2 95 | , "'" 96 | ] 97 | 98 | 99 | varBind :: TName -> Type -> TI Subst 100 | varBind u t 101 | | t == TVar u = pure mempty 102 | | S.member u (free t) = throwE 103 | $ mconcat 104 | [ "occurs check: '" 105 | , show u 106 | , "' vs '" 107 | , show t 108 | , "'" 109 | ] 110 | | otherwise = do 111 | k <- kind t 112 | when (k /= tKind u) $ throwE "kind unification fails" 113 | pure $ Subst [(u, t)] 114 | 115 | 116 | splatter :: Monad f => c -> Scope b f c -> f c 117 | splatter = splat pure . const . pure 118 | 119 | 120 | inferLit :: Lit -> Type 121 | inferLit (LitInt _) = TInt 122 | inferLit (LitString _) = TString 123 | inferLit (LitNative _ t) = t 124 | 125 | 126 | infer 127 | :: SymTable VName 128 | -> Exp VName 129 | -> TI ([Pred], Type, Placeholder (Exp VName)) 130 | infer env (Assert e t) = do 131 | (p1, t1, h1) <- infer env e 132 | unify t t1 133 | s <- view tiSubst <$> get 134 | pure (sub s p1, t, Assert <$> h1 <*> pure t) 135 | 136 | infer (SymTable env) (V a) = 137 | case M.lookup a env of 138 | Nothing -> throwE $ "unbound variable: '" <> show a <> "'" 139 | Just sigma -> do 140 | (ps :=> x, h) <- freshInst a sigma 141 | pure (ps, x, h) 142 | 143 | infer (SymTable env) z@(LCon a) = 144 | case M.lookup a env of 145 | Nothing -> throwE $ "unbound variable: '" <> show a <> "'" 146 | Just sigma -> do 147 | (ps :=> x, _) <- freshInst a sigma 148 | pure (ps, x, pure z) 149 | 150 | infer env (Let n e1 b) = do 151 | name <- newVName "v" 152 | let e2 = splatter name b 153 | (p1, t1, h1) <- infer env e1 154 | let t' = generalize env $ p1 :=> t1 155 | env' = SymTable $ M.insert name t' $ unSymTable env 156 | (p2, t2, h2) <- infer env' e2 157 | pure (p2, t2, let_ <$> pure n <*> h1 <*> h2) 158 | infer _ h@(Lit l) = pure (mempty, inferLit l, pure h) 159 | 160 | infer env (Case e ps) = do 161 | t <- newTyVar KStar 162 | (p1, te, h1) <- infer env e 163 | (p2, tps, h2) <- fmap unzip3 $ for ps $ \(pat, pexp) -> do 164 | (as, ts) <- inferPattern env pat 165 | unify te ts 166 | let env' = SymTable $ M.fromList (as <&> \(i :>: x) -> (i, x)) 167 | <> unSymTable env 168 | pexp' = instantiate V pexp 169 | (p2, tp, h2) <- infer env' pexp' 170 | unify t tp 171 | pure (p2, tp, (,) <$> pure pat <*> h2) 172 | 173 | for_ (zip tps $ tail tps) $ uncurry $ flip unify 174 | 175 | pure (p1 <> join p2, t, case_ <$> h1 <*> sequence h2) 176 | 177 | infer (SymTable env) (Lam name x) = do 178 | tv <- newTyVar KStar 179 | let env' = SymTable $ env <> [(name, mkScheme tv)] 180 | e = splatter name x 181 | (p1, t1, h1) <- infer env' e 182 | pure (p1, TArr tv t1, lam <$> pure name <*> h1) 183 | 184 | infer env exp@(e1 :@ e2) = 185 | do 186 | tv <- newTyVar KStar 187 | (p1, t1, h1) <- infer env e1 188 | (p2, t2, h2) <- infer env e2 189 | unify t1 $ TArr t2 tv 190 | pure (p1 <> p2, tv, (:@) <$> h1 <*> h2) 191 | `catchE` \e -> throwE $ 192 | mconcat 193 | [ e 194 | , "\n in " 195 | , show exp 196 | -- , "\n\ncontext: \n" 197 | -- , foldMap ((<> "\n") . show) . M.assocs $ unSymTable env 198 | ] 199 | 200 | 201 | inferPattern :: SymTable VName -> Pat -> TI ([Assump Scheme], Type) 202 | inferPattern _ (PLit l) = do 203 | pure (mempty, inferLit l) 204 | inferPattern _ PWildcard = do 205 | ty <- newTyVar KStar 206 | pure (mempty, ty) 207 | inferPattern _ (PVar x) = do 208 | ty <- newTyVar KStar 209 | pure (pure $ x :>: mkScheme ty, ty) 210 | inferPattern st (PAs x p) = do 211 | (as, t) <- inferPattern st p 212 | pure (x :>: mkScheme t : as, t) 213 | inferPattern st (PCon c ps) = do 214 | t <- newTyVar KStar 215 | (as, ts) <- first join . unzip <$> for ps (inferPattern st) 216 | -- this is gross! there is a bug here if the type constructor has constraints 217 | -- on it 218 | (_, ct, _) <- infer st $ V c 219 | unify ct $ foldr (:->) t ts 220 | pure (as, t) 221 | 222 | 223 | typeInference 224 | :: ClassEnv 225 | -> SymTable VName 226 | -> Exp VName 227 | -> TI ((Qual Type, Type), Exp VName) 228 | typeInference cenv sym e = do 229 | (ps, t, h) <- infer sym e 230 | s <- view tiSubst <$> get 231 | zs <- traverse (discharge cenv) $ sub (flatten s) ps 232 | let (s', ps', m, as, _) = mconcat zs 233 | s'' = flatten $ s <> s' 234 | (ps'' :=> t') = sub s'' $ ps' :=> t 235 | t'' = nub ps'' :=> t' 236 | m' = M.mapKeys (sub s'') m 237 | h' = runReader h $ (M.!) m' . sub s'' 238 | e' = foldr lam h' $ fmap assumpName as 239 | te' = foldr (:->) (unqualType t'') $ fmap assumpVal as 240 | _ <- errorAmbiguous t'' 241 | pure ((t'', te'), e') 242 | `catchE` \err -> throwE $ 243 | mconcat 244 | [ err 245 | , "\n in " 246 | , show e 247 | ] 248 | 249 | 250 | flatten :: Subst -> Subst 251 | flatten (Subst x) = fix $ \(Subst final) -> 252 | Subst $ M.fromList $ M.assocs x <&> \(a, b) -> (a,) $ 253 | sub (Subst final) $ case b of 254 | TVar n -> maybe (TVar n) id $ M.lookup n final 255 | z -> z 256 | 257 | 258 | generalize :: SymTable a -> Qual Type -> Scheme 259 | generalize env t = 260 | Scheme (S.toList $ free t S.\\ free env) t 261 | 262 | 263 | discharge 264 | :: ClassEnv 265 | -> Pred 266 | -> TI ( Subst 267 | , [Pred] 268 | , Map Pred (Exp VName) 269 | , [Assump Type] 270 | , [Exp VName] 271 | ) 272 | discharge cenv p = do 273 | x <- for (getQuals cenv) $ \(a :=> b) -> do 274 | s <- (fmap (a, b,) <$> match' b p) <|> pure Nothing 275 | pure $ First s 276 | case getFirst $ mconcat x of 277 | Just (ps, b, s) -> do 278 | (s', ps', mp, as, ds) <- fmap mconcat 279 | . traverse (discharge cenv) 280 | $ sub s ps 281 | let d = V . VName $ getDict b 282 | e = foldl (:@) d ds 283 | pure $ (s', ps', mp <> M.singleton p e, as, pure e) 284 | Nothing -> do 285 | param <- newVName "d" 286 | pure ( mempty 287 | , pure p 288 | , M.singleton p $ V param 289 | , pure $ param :>: getDictTypeForPred p 290 | , pure $ V param 291 | ) 292 | `catchE` \e -> throwE $ 293 | mconcat 294 | [ e 295 | , "\n when discharging " 296 | , show p 297 | ] 298 | 299 | 300 | errorAmbiguous :: Qual Type -> TI (Qual Type) 301 | errorAmbiguous (t@(a :=> b)) = do 302 | let amb = S.toList $ free a S.\\ free b 303 | when (amb /= mempty) . throwE $ mconcat 304 | [ "the type variable" 305 | , bool "" "s" $ null amb 306 | , " '" 307 | , intercalate "', '" $ fmap show amb 308 | , "' " 309 | , bool "is" "are" $ null amb 310 | , " ambiguous\n" 311 | , "in the type '" 312 | , show t 313 | , "'\n" 314 | ] 315 | pure t 316 | 317 | 318 | -- | Unlike 'unify', the order of the paremeters here matters. 319 | match :: Type -> Type -> TI Subst 320 | match (l :@@ r) (l' :@@ r') = do 321 | sl <- match l l' 322 | sr <- match r r' 323 | pure . Subst $ unSubst sl <> unSubst sr 324 | match (TVar u) t = pure $ Subst [(u, t)] 325 | match (TCon tc1) (TCon tc2) 326 | | tc1 == tc2 = pure mempty 327 | match t1 t2 = throwE $ mconcat 328 | [ "types do not match: '" 329 | , show t1 330 | , "' vs '" 331 | , show t2 332 | , "'\n" 333 | ] 334 | 335 | match' :: Pred -> Pred -> TI (Maybe Subst) 336 | match' (IsInst a b) (IsInst a' b') 337 | | a /= a' = pure Nothing 338 | | otherwise = Just <$> match b b' 339 | 340 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE PatternSynonyms #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# OPTIONS_GHC -Wall #-} 13 | 14 | module Types where 15 | 16 | import Bound 17 | import Control.Lens ((<&>)) 18 | import Control.Monad.State 19 | import Data.Bifunctor (second) 20 | import Data.Bool (bool) 21 | import Data.Char (isLower, isUpper, isSymbol, isPunctuation) 22 | import Data.Eq.Deriving (deriveEq1) 23 | import Data.List (intercalate) 24 | import Data.Map (Map) 25 | import qualified Data.Map as M 26 | import Data.Semigroup (Semigroup (..)) 27 | import Data.Set (Set) 28 | import qualified Data.Set as S 29 | import GHC.Exts (IsString (..)) 30 | import Prelude hiding (exp) 31 | import Text.Show.Deriving (deriveShow1) 32 | 33 | 34 | infixl 9 :@@ 35 | data Type 36 | = TVar TName 37 | | TCon TName 38 | | Type :@@ Type 39 | deriving (Eq, Ord) 40 | 41 | 42 | 43 | infixr 9 :>> 44 | data Kind 45 | = KStar 46 | | KConstraint 47 | | Kind :>> Kind 48 | deriving (Eq, Ord) 49 | 50 | 51 | instance Show Kind where 52 | showsPrec _ KStar = showString "*" 53 | showsPrec _ KConstraint = showString "Constraint" 54 | showsPrec x (a :>> b) = showParen (x > 0) 55 | $ showsPrec 1 a 56 | . showString " -> " 57 | . showsPrec 0 b 58 | 59 | 60 | pattern TK2 :: String -> Type -> Type -> Type 61 | pattern TK2 c a b = TVar (TName c K2) :@@ a :@@ b 62 | 63 | pattern K2 :: Kind 64 | pattern K2 = KStar :>> KStar :>> KStar 65 | 66 | pattern TK1 :: String -> Type -> Type 67 | pattern TK1 c a = TVar (TName c K1) :@@ a 68 | 69 | pattern K1 :: Kind 70 | pattern K1 = KStar :>> KStar 71 | 72 | 73 | pattern TProd :: Type -> Type -> Type 74 | pattern TProd a b = TCon (TName "," K2) :@@ a :@@ b 75 | 76 | pattern TSum :: Type -> Type -> Type 77 | pattern TSum a b = TCon (TName "+" K2) :@@ a :@@ b 78 | 79 | pattern TArr :: Type -> Type -> Type 80 | pattern TArr a b = TArrCon :@@ a :@@ b 81 | 82 | pattern TArrCon :: Type 83 | pattern TArrCon = TCon (TName "->" K2) 84 | 85 | pattern TBool :: Type 86 | pattern TBool = "2" 87 | 88 | pattern TUnit :: Type 89 | pattern TUnit = "1" 90 | 91 | pattern TString :: Type 92 | pattern TString = "String" 93 | 94 | pattern TInt :: Type 95 | pattern TInt = "Int" 96 | 97 | 98 | pattern TCat :: String -> Type -> Type -> Type 99 | pattern TCat k a b = TK2 k a b 100 | 101 | 102 | instance IsString Type where 103 | fromString x = 104 | case isLower $ head x of 105 | False -> TCon $ fromString x 106 | True -> TVar $ fromString x 107 | 108 | 109 | instance Show Type where 110 | showsPrec x (TArr a b) = showParen (x > 0) 111 | $ showsPrec 1 a 112 | . showString " -> " 113 | . showsPrec 0 b 114 | showsPrec x (TProd a b) = showParen (x > 3) 115 | $ showsPrec 4 a 116 | . showString " * " 117 | . showsPrec 4 b 118 | showsPrec x (TSum a b) = showParen (x > 5) 119 | $ showsPrec 6 a 120 | . showString " + " 121 | . showsPrec 6 b 122 | showsPrec _ (TVar n) = showString $ unTName n 123 | showsPrec _ (TCon n) = 124 | showParen (all ((||) <$> isSymbol <*> isPunctuation) $ unTName n) 125 | $ showString $ unTName n 126 | showsPrec x (a :@@ b) = showParen (x > 9) 127 | $ showsPrec 9 a 128 | . showString " " 129 | . showsPrec 10 b 130 | 131 | 132 | data TName 133 | = TName String Kind 134 | | TFreshName String Kind 135 | deriving (Eq, Ord) 136 | 137 | 138 | instance IsString TName where 139 | fromString = flip TName KStar 140 | 141 | 142 | instance Show TName where 143 | show = unTName 144 | 145 | 146 | unTName :: TName -> String 147 | unTName (TName a _) = a 148 | unTName (TFreshName a _) = a 149 | 150 | 151 | tKind :: TName -> Kind 152 | tKind (TName _ k) = k 153 | tKind (TFreshName _ k) = k 154 | 155 | 156 | data Pat 157 | = PVar VName 158 | | PWildcard 159 | | PAs VName Pat 160 | | PCon VName [Pat] 161 | | PLit Lit 162 | deriving (Eq, Ord) 163 | 164 | 165 | instance IsString Pat where 166 | fromString = PVar . fromString 167 | 168 | 169 | pattern PFalse :: Pat 170 | pattern PFalse = PCon "False" [] 171 | 172 | 173 | pattern PTrue :: Pat 174 | pattern PTrue = PCon "True" [] 175 | 176 | pattern PProd :: Pat -> Pat -> Pat 177 | pattern PProd a b = PCon "," [a, b] 178 | 179 | 180 | 181 | -- | a new variable to introduce 182 | data Assump a = (:>:) 183 | { assumpName :: VName 184 | , assumpVal :: a 185 | } 186 | deriving (Eq, Ord, Show) 187 | 188 | 189 | data Scheme = Scheme 190 | { schemeVars :: [TName] 191 | , schemeType :: Qual Type 192 | } 193 | deriving (Eq, Ord) 194 | 195 | 196 | mkScheme :: Type -> Scheme 197 | mkScheme t = Scheme mempty $ [] :=> t 198 | 199 | 200 | infixr 0 :=> 201 | data Qual t = (:=>) 202 | { qualPreds :: [Pred] 203 | , unqualType :: t 204 | } deriving (Eq, Ord, Functor, Traversable, Foldable) 205 | 206 | data Pred = IsInst 207 | { predCName :: TName 208 | , predInst :: Type 209 | } deriving (Eq, Ord) 210 | 211 | 212 | infixl 9 :@ 213 | data Exp a 214 | = V a 215 | | Lit Lit 216 | | LCon VName 217 | | Exp a :@ Exp a 218 | | Lam VName (Scope () Exp a) 219 | | Let VName (Exp a) (Scope () Exp a) 220 | | Case (Exp a) [(Pat, Scope VName Exp a)] 221 | | Assert (Exp a) Type 222 | deriving (Functor, Foldable, Traversable) 223 | 224 | 225 | data Lit 226 | = LitInt Int 227 | | LitString String 228 | | LitNative String Type 229 | deriving (Eq, Ord) 230 | 231 | instance Show Lit where 232 | showsPrec _ (LitInt i) = showString $ show i 233 | showsPrec _ (LitString i) = showString $ show i 234 | showsPrec _ (LitNative a t) = 235 | showsPrec 10 $ Assert (V (VName "NATIVE") :@ V (VName a)) t 236 | 237 | 238 | instance IsString a => IsString (Exp a) where 239 | fromString x = 240 | case isUpper $ head x of 241 | True -> LCon $ fromString x 242 | False -> V $ fromString x 243 | 244 | 245 | instance Applicative Exp where 246 | pure = V 247 | (<*>) = ap 248 | 249 | 250 | instance Monad Exp where 251 | return = pure 252 | V a >>= f = f a 253 | LCon a >>= _ = LCon a 254 | Lit i >>= _ = Lit i 255 | (x :@ y) >>= f = (x >>= f) :@ (y >>= f) 256 | Lam n e >>= f = Lam n (e >>>= f) 257 | Let n bs b >>= f = Let n (bs >>= f) (b >>>= f) 258 | Assert e t >>= f = Assert (e >>= f) t 259 | Case e p >>= f = Case (e >>= f) $ fmap (second (>>>= f)) p 260 | 261 | 262 | pattern LInt :: Int -> Exp a 263 | pattern LInt i = Lit (LitInt i) 264 | 265 | pattern LString :: String -> Exp a 266 | pattern LString s = Lit (LitString s) 267 | 268 | pattern LProd :: Exp a -> Exp a -> Exp a 269 | pattern LProd a b = LCon "," :@ a :@ b 270 | 271 | 272 | newtype VName = VName { unVName :: String } 273 | deriving (Eq, Ord, IsString, Monoid) 274 | 275 | 276 | instance Show VName where 277 | show = unVName 278 | 279 | 280 | deriveEq1 ''Exp 281 | deriveShow1 ''Exp 282 | 283 | deriving instance Eq a => Eq (Exp a) 284 | deriving instance {-# OVERLAPPABLE #-} Show a => Show (Exp a) 285 | deriving instance Show Scheme 286 | 287 | instance Show Pat where 288 | showsPrec _ PWildcard = showString "_" 289 | showsPrec _ (PVar x) = showString $ show x 290 | showsPrec _ (PAs x p) = 291 | showString (show x) 292 | . showString "@" 293 | . showsPrec 10 p 294 | showsPrec _ (PLit l) = showString $ show l 295 | showsPrec x (PCon n ps) = showParen (x > 0) 296 | $ showsPrec 10 (LCon n :: Exp VName) 297 | . foldl (.) id (fmap ((showString " " .) . showsPrec 10) ps) 298 | 299 | 300 | data GenDataCon = GenDataCon 301 | { gdcName :: VName 302 | , gdcConType :: Qual Type 303 | , gdcFinalType :: Qual Type 304 | , gdcCon :: Exp VName 305 | } deriving (Eq, Show) 306 | 307 | 308 | data CompUnit = CompUnit 309 | { cuClasses :: [Class] 310 | , cuInsts :: [InstRep Pred] 311 | , cuGDCs :: [GenDataCon] 312 | , cuRecords :: [(GenDataCon, [(VName, (Qual Type, Exp VName))])] 313 | , cuDecls :: Map VName (Qual Type, Exp VName) 314 | } deriving (Eq, Show) 315 | 316 | 317 | instance Show (Exp VName) where 318 | showsPrec x (V a) = 319 | showParen ((||) <$> all ((||) <$> isSymbol <*> isPunctuation) <*> elem ' ' $ unVName a) 320 | $ showsPrec x a 321 | showsPrec x (LCon a) = 322 | showsPrec x (TCon (TName (unVName a) KStar)) 323 | . showString "#" 324 | showsPrec x (V "." :@ a :@ b) = 325 | showParen (x >= 9) 326 | $ showsPrec 9 a 327 | . showString " . " 328 | . showsPrec 9 b 329 | showsPrec x (a :@ b) = 330 | showParen (x >= 10) 331 | $ showsPrec 9 a 332 | . showString " " 333 | . showsPrec 10 b 334 | showsPrec _ (Lit l) = showString $ show l 335 | showsPrec x (Lam n z) = showParen (x >= 2) 336 | $ showString "λ" 337 | . showString (show n) 338 | . showString ". " 339 | . showsPrec 1 (instantiate1 (V n) z) 340 | showsPrec x (Let n b e) = showParen (x > 0) 341 | $ showString "let " 342 | . showString (show n) 343 | . showString " = " 344 | . showsPrec 0 b 345 | . showString " in " 346 | . showsPrec 0 (instantiate1 (V n) e) 347 | showsPrec _ (LProd a b) = showParen True 348 | $ showsPrec 0 a 349 | . showString ", " 350 | . showsPrec 0 b 351 | showsPrec x (Assert e t) = showParen (x > 0) 352 | $ showsPrec 0 e 353 | . showString " :: " 354 | . showsPrec 0 t 355 | showsPrec x (Case e ps) = showParen (x >= 2) 356 | $ showString "case " 357 | . showsPrec 0 e 358 | . showString " of {" 359 | . (drop 1 . foldl (.) id 360 | (ps <&> \(p, pe) -> 361 | showString "; " 362 | . showsPrec 0 p 363 | . showString " -> " 364 | . showsPrec 0 (instantiate V pe))) 365 | . showString " }" 366 | 367 | 368 | 369 | instance Show t => Show (Qual t) where 370 | show (a :=> b) = 371 | case length a of 372 | 0 -> show b 373 | 1 -> show (head a) <> " => " <> show b 374 | _ -> mconcat 375 | [ "(" 376 | , intercalate ", " $ fmap show a 377 | , ") => " 378 | , show b 379 | ] 380 | 381 | 382 | instance Show Pred where 383 | show (IsInst a b) = show a <> " (" <> show b <> ")" 384 | 385 | 386 | 387 | data Class = Class 388 | { cVars :: TName 389 | , cName :: TName 390 | , cMethods :: Map VName (Qual Type) 391 | } deriving (Eq, Ord, Show) 392 | 393 | 394 | pattern (:->) :: Type -> Type -> Type 395 | pattern (:->) a b = TArr a b 396 | infixr 1 :-> 397 | 398 | 399 | class Types a where 400 | free :: a -> Set TName 401 | sub :: Subst -> a -> a 402 | 403 | 404 | instance Types a => Types (Assump a) where 405 | free (_ :>: a) = free a 406 | sub s (x :>: a) = x :>: sub s a 407 | 408 | 409 | instance Types Type where 410 | free (TVar a) = S.fromList [a] 411 | free (TCon _) = S.fromList [] -- ? 412 | free (a :@@ b) = free a <> free b 413 | 414 | sub s (TVar n) = maybe (TVar n) id $ M.lookup n $ unSubst s 415 | sub _ (TCon n) = TCon n 416 | sub s (a :@@ b) = sub s a :@@ sub s b 417 | 418 | 419 | instance Types a => Types [a] where 420 | free = mconcat . fmap free 421 | sub s = fmap (sub s) 422 | 423 | 424 | instance Types a => Types (Qual a) where 425 | free (a :=> b) = free a <> free b 426 | sub s (a :=> b) = sub s a :=> sub s b 427 | 428 | 429 | instance Types Pred where 430 | free (IsInst _ a) = free a 431 | sub s (IsInst a b) = IsInst a (sub s b) 432 | 433 | 434 | instance Types Scheme where 435 | free (Scheme vars t) = free t S.\\ S.fromList vars 436 | 437 | -- sub all `s` that are not quantified? 438 | sub s (Scheme vars t) = 439 | Scheme vars $ sub (Subst $ foldr M.delete (unSubst s) vars) t 440 | 441 | 442 | newtype Subst = Subst 443 | { unSubst :: Map TName Type } 444 | deriving (Eq, Show) 445 | 446 | 447 | instance Monoid Subst where 448 | mempty = Subst mempty 449 | mappend s1 (Subst s2) = 450 | Subst $ fmap (sub s1) s2 <> unSubst s1 451 | 452 | 453 | newtype ClassEnv = ClassEnv 454 | { unClassEnv :: Map Pred (InstRep ()) 455 | } deriving (Eq, Show, Monoid) 456 | 457 | 458 | data InstRep a = InstRep 459 | { irQuals :: Qual a 460 | , irImpls :: Map VName (Exp VName) 461 | } deriving (Eq, Show, Functor) 462 | 463 | 464 | getQuals :: ClassEnv -> [Qual Pred] 465 | getQuals = fmap (\(a, b) -> a <$ irQuals b) . M.assocs . unClassEnv 466 | 467 | getInstReps :: ClassEnv -> [InstRep Pred] 468 | getInstReps = fmap (\(p, i) -> p <$ i) . M.assocs . unClassEnv 469 | 470 | 471 | newtype SymTable a = SymTable 472 | { unSymTable :: Map a Scheme 473 | } deriving (Eq, Ord, Show) 474 | 475 | 476 | instance Types (SymTable a) where 477 | free = free . M.elems . unSymTable 478 | sub s = SymTable . fmap (sub s) . unSymTable 479 | 480 | 481 | pattern CCat :: String -> Pred 482 | pattern CCat t = IsInst "Category" (TVar (TName t K2)) 483 | 484 | pattern CCart :: String -> Pred 485 | pattern CCart t = IsInst "Cartesian" (TVar (TName t K2)) 486 | 487 | pattern CTerm :: String -> Pred 488 | pattern CTerm t = IsInst "Terminal" (TVar (TName t K2)) 489 | 490 | pattern CClosed :: String -> Pred 491 | pattern CClosed t = IsInst "Closed" (TVar (TName t K2)) 492 | 493 | 494 | lam :: VName -> Exp VName -> Exp VName 495 | lam x e = Lam x (abstract1 x e) 496 | 497 | case_ :: Exp VName -> [(Pat, Exp VName)] -> Exp VName 498 | case_ e ps 499 | = Case e 500 | . flip fmap ps 501 | $ \(p, ep) -> (p, abstract 502 | (\x -> bool Nothing (Just x) $ elem x $ pVars p) ep) 503 | 504 | pVars :: Pat -> [VName] 505 | pVars PWildcard = [] 506 | pVars (PVar i) = pure i 507 | pVars (PAs i p) = i : pVars p 508 | pVars (PCon _ p) = foldMap pVars p 509 | pVars (PLit _) = [] 510 | 511 | let_ :: VName -> Exp VName -> Exp VName -> Exp VName 512 | let_ x v = Let x v . abstract1 x 513 | 514 | -------------------------------------------------------------------------------- /src/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TupleSections #-} 5 | {-# OPTIONS_GHC -Wall #-} 6 | 7 | module Utils where 8 | 9 | import Control.Lens ((<&>), makeLenses) 10 | import Control.Monad.State 11 | import Control.Monad.Trans.Except 12 | import Data.Bifunctor (first, second) 13 | import Data.List (nub) 14 | import qualified Data.Map as M 15 | import Data.Monoid ((<>)) 16 | import qualified Data.Set as S 17 | import Debug.Trace (trace) 18 | import Types 19 | 20 | 21 | showTrace :: Show b => b -> b 22 | showTrace = trace =<< show 23 | 24 | 25 | data TIState = TIState 26 | { _tiVNames :: Int 27 | , _tiTNames :: Int 28 | , _tiSubst :: Subst 29 | } 30 | 31 | makeLenses ''TIState 32 | 33 | type TI = ExceptT String (State TIState) 34 | 35 | 36 | unravel :: Exp a -> Maybe (VName, [Exp a]) 37 | unravel = go [] 38 | where 39 | go acc (LCon a) = pure (a, acc) 40 | go acc (a :@ b) = go (b : acc) a 41 | go _ _ = Nothing 42 | 43 | 44 | unravelNative :: Exp a -> Maybe (String, [Exp a]) 45 | unravelNative = go [] 46 | where 47 | go acc (Lit (LitNative a _)) = pure (a, acc) 48 | go acc (a :@ b) = go (b : acc) a 49 | go _ _ = Nothing 50 | 51 | 52 | letters :: [String] 53 | letters = do 54 | b <- "":letters 55 | a <- ['a'..'z'] 56 | pure $ a : b 57 | 58 | 59 | runTI :: TI a -> Either String a 60 | runTI = flip evalState (TIState 0 0 mempty) . runExceptT 61 | 62 | 63 | kind :: Type -> TI Kind 64 | kind (TVar x) = pure $ tKind x 65 | kind (TCon x) = pure $ tKind x 66 | kind (a :@@ b) = do 67 | ka <- kind a 68 | kb <- kind b 69 | let kerr kk = throwE $ mconcat 70 | [ "kind mismatch: '" 71 | , show b 72 | , " :: " 73 | , show kb 74 | , "' vs '" 75 | , show kk 76 | , "'\nwhen trying to apply '" 77 | , show a 78 | , " :: " 79 | , show ka 80 | , "'\n" 81 | ] 82 | case ka of 83 | kal :>> kar -> do 84 | when (kal /= kb) $ kerr kal 85 | pure kar 86 | KStar -> kerr KStar 87 | KConstraint -> kerr KConstraint 88 | 89 | 90 | 91 | buildDataCon 92 | :: VName 93 | -> [Type] 94 | -> Maybe Type 95 | -> GenDataCon 96 | buildDataCon n@(VName s) ts t' = 97 | let ks = fmap (either error id . runTI . kind) ts 98 | k = foldr (:>>) KStar ks 99 | tr = maybe (foldl (:@@) (TCon $ TName s k) 100 | . fmap TVar 101 | $ S.toList $ free ts) id t' 102 | t = foldr (:->) tr ts 103 | ls = fmap fst $ zip (fmap VName letters) ts 104 | in GenDataCon n ([] :=> t) ([] :=> tr) 105 | . foldr lam 106 | (foldl (:@) (LCon n) $ fmap V ls) 107 | $ ls 108 | 109 | 110 | buildRecord 111 | :: VName 112 | -> [(VName, Type)] 113 | -> Maybe Type 114 | -> (GenDataCon, [(VName, (Qual Type, Exp VName))]) 115 | buildRecord n fs t = 116 | let gen@(GenDataCon _ _ t' _) = buildDataCon n (fmap snd fs) t 117 | in (gen, ) 118 | $ zip [0..] fs <&> \(fn, (f, ft)) -> 119 | let p = take (length fs) $ putBack $ splitAt fn $ repeat PWildcard 120 | putBack (as, bs) = as <> [PVar "p"] <> bs 121 | in (f,) 122 | $ ([] :=> unqualType t' :-> ft,) 123 | $ lam "z" 124 | $ case_ "z" 125 | $ [(PCon n p, "p")] 126 | 127 | 128 | getDictName :: TName -> Type 129 | getDictName n = TCon . TName (getDictName2 n) $ tKind n 130 | 131 | getDictName2 :: TName -> String 132 | getDictName2 n = "@" <> unTName n 133 | 134 | 135 | getDictTypeForPred :: Pred -> Type 136 | getDictTypeForPred (IsInst c t) = getDictName c :@@ t 137 | 138 | getDict :: Pred -> String 139 | getDict (IsInst c t) = "@" <> show c <> "@" <> show (normalizeType2 t) 140 | 141 | 142 | 143 | 144 | buildDictType 145 | :: Class 146 | -> (GenDataCon, [(VName, (Qual Type, Exp VName))]) 147 | buildDictType c@(Class v n ms) = 148 | second (fmap (second $ first $ dictToConstraint c)) 149 | $ 150 | buildRecord 151 | (VName name) 152 | -- TODO(sandy): there is a bug here if there is a constraint on the method 153 | (fmap (second unqualType) $ M.assocs ms) 154 | $ Just ((TVar $ TName name $ tKind n) :@@ TVar v) 155 | -- (Just $ TCon (TName name KStar)) 156 | where 157 | name = getDictName2 n 158 | 159 | 160 | buildDict :: GenDataCon -> InstRep Pred -> (VName, (Qual Type, Exp VName)) 161 | buildDict gdc (InstRep (_ :=> i@(IsInst c t)) impls) = 162 | (VName dict,) 163 | -- TODO(sandy): buggy; doesn't do nested dicts 164 | -- TODO(sandy): also buggy. we should just run the type checker on this 165 | $ (sub (Subst $ M.fromList [("a", t)] ) $ gdcFinalType gdc,) 166 | $ foldl (:@) (LCon (VName dname)) $ M.elems impls 167 | where 168 | dict = getDict i 169 | dname = getDictName2 c 170 | 171 | 172 | dictToConstraint :: Class -> Qual Type -> Qual Type 173 | dictToConstraint (Class v n _) (qs :=> (_ :-> t)) = 174 | (IsInst n $ TVar v) : qs :=> t 175 | 176 | 177 | 178 | normalizeType :: Qual Type -> Qual Type 179 | normalizeType = schemeType . normalize . Scheme mempty 180 | 181 | 182 | normalizeType2 :: Type -> Type 183 | normalizeType2 = unqualType . normalizeType . ([] :=>) 184 | 185 | 186 | normalize :: Scheme -> Scheme 187 | normalize (Scheme _ body) = 188 | Scheme (fmap snd ord) $ normqual body 189 | where 190 | ord = zip (nub . S.toList $ free body) letters <&> \(old, l) -> 191 | (old, TName l $ tKind old) 192 | normqual (xs :=> zs) = 193 | fmap (\(IsInst c t) -> IsInst c $ normtype t) xs :=> normtype zs 194 | 195 | normtype (TCon a) = TCon a 196 | normtype (a :@@ b) = normtype a :@@ normtype b 197 | normtype (TVar a) = 198 | case lookup a ord of 199 | Just x -> TVar $ TName (unTName x) (tKind x) 200 | Nothing -> error "type variable not in signature" 201 | 202 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.0 2 | 3 | packages: 4 | - '.' 5 | 6 | extra-deps: 7 | 8 | flags: {} 9 | 10 | extra-package-dbs: [] 11 | 12 | -------------------------------------------------------------------------------- /test/CCCSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module CCCSpec where 5 | 6 | import CCC 7 | import Data.List (partition) 8 | import Data.Monoid ((<>)) 9 | import StdLib 10 | import Test.Hspec 11 | import TypeChecking 12 | import Types 13 | 14 | fromRight (Right a) = a 15 | 16 | 17 | cccType :: Exp VName -> Qual Type -> SpecWith () 18 | cccType e (q :=> t) = it (show e) $ 19 | test' (toCCC e) `shouldBe` Right (q :=> t) 20 | 21 | cccDidntInline :: Exp VName -> Qual Type -> SpecWith () 22 | cccDidntInline e (q :=> t) = it ("to inline: " <> show e) $ do 23 | let Right (q' :=> t') = test' $ toCCC e 24 | (i, q'') = partition ((== "ToInline") . predCName) q' 25 | (q'' :=> t') `shouldBe` (q :=> t) 26 | i `shouldNotBe` [] 27 | 28 | 29 | spec :: Spec 30 | spec = do 31 | pure () 32 | -- describe "type checking" $ do 33 | -- cccType (lam "x" "x") $ 34 | -- [CCat "b"] :=> TCat "b" "a" "a" 35 | 36 | -- cccType (lam "x" $ lam "y" $ "," :@ "x" :@ "y") $ 37 | -- [CCat "c"] 38 | -- :=> TCat "c" (TProd "a" "b") (TProd "a" "b") 39 | 40 | -- cccType (lam "x" $ lam "y" $ LProd "x" "y") $ 41 | -- [CCat "c"] 42 | -- :=> TCat "c" (TProd "a" "b") (TProd "a" "b") 43 | 44 | -- cccType (lam "x" $ lam "y" $ LProd "y" "x") $ 45 | -- [CCat "c"] 46 | -- :=> TCat "c" (TProd "a" "b") (TProd "b" "a") 47 | -- cccType (lam "z" $ LProd ("snd" :@ "z") ("fst" :@ "z")) $ 48 | -- [CCat "c"] 49 | -- :=> TCat "c" (TProd "a" "b") (TProd "b" "a") 50 | -- cccDidntInline "swap" $ 51 | -- [CCat "c"] 52 | -- :=> TCat "c" (TProd "a" "b") (TProd "b" "a") 53 | 54 | 55 | -- cccType (lam "x" $ lam "y" $ LProd (LInt 5) LTrue) $ 56 | -- [CCat "b"] 57 | -- :=> TCat "b" "a" (TProd TInt TBool) 58 | 59 | -- cccType (lam "x" $ "fst") $ 60 | -- [CCat "b"] 61 | -- :=> TCat "b" "a" (TProd "c" "d" :-> "c") 62 | 63 | -- cccType "fst" $ 64 | -- [CCat "c"] 65 | -- :=> TCat "c" (TProd "a" "b") "a" 66 | 67 | -------------------------------------------------------------------------------- /test/EvalSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module EvalSpec where 6 | 7 | import Data.Bool (bool) 8 | import Data.Foldable (for_) 9 | import qualified Data.Map as M 10 | import Data.Monoid ((<>)) 11 | import Evaluation hiding (eval) 12 | import StdLib 13 | import Test.Hspec 14 | import TypeChecking 15 | import Types 16 | import Utils 17 | 18 | 19 | eval :: Exp VName -> Exp VName -> SpecWith () 20 | eval v e = it (show e <> " |=> " <> show v) $ 21 | whnf prelude e `shouldBe` v 22 | 23 | evalDicts :: Exp VName -> Exp VName -> SpecWith () 24 | evalDicts v e = it (show e <> " |=> " <> show v) $ do 25 | let Right (_, e') = test'' e 26 | whnf prelude e' `shouldBe` v 27 | 28 | 29 | getDef :: VName -> Exp VName 30 | getDef n = prelude M.! n 31 | 32 | 33 | spec :: Spec 34 | spec = do 35 | describe "evaluation" $ do 36 | eval (LInt 5) $ LInt 5 37 | eval (LString "hello") $ LString "hello" 38 | 39 | eval "False" $ "False" 40 | eval (LProd "fst" "snd") $ LProd "fst" "snd" 41 | eval (getDef "fst") $ "fst" :@ LProd "fst" "snd" 42 | 43 | let myPats = 44 | [ ( PCon "Inl" [PLit (LitInt 5)] 45 | , LInt 1 46 | ) 47 | , ( PCon "Inl" [PVar "z"] 48 | , "z" 49 | ) 50 | , ( PCon "Inr" [PWildcard] 51 | , LInt $ -15 52 | ) 53 | ] 54 | 55 | eval (LInt 1) $ case_ ("Inl" :@ LInt 5) myPats 56 | eval (LInt 2) $ case_ ("Inl" :@ LInt 2) myPats 57 | eval (LInt 3) $ case_ ("Inl" :@ LInt 3) myPats 58 | eval (LInt $ -15) $ case_ ("Inr" :@ LInt 3) myPats 59 | 60 | eval (LString "yo") $ case_ (LString "hello") 61 | [ ( PLit (LitString "hello"), LString "yo" ) 62 | , ( PWildcard, LString "bad" ) 63 | ] 64 | 65 | let prod = LProd (LInt 1) (LInt 2) 66 | eval prod $ case_ prod 67 | [( PAs "i" $ PCon "," [PVar "x", PVar "y"], "i")] 68 | eval (LInt 2) $ case_ prod 69 | [( PAs "i" $ PCon "," [PVar "x", PVar "y"], "y")] 70 | 71 | let idF = lam "x" "x" 72 | eval idF idF 73 | 74 | eval "True" $ let_ "x" "True" "x" 75 | eval (LInt 7) $ let_ "x" "True" $ 76 | "fst" :@ LProd (LInt 7) "x" 77 | eval "True" $ let_ "x" "True" $ 78 | "snd" :@ LProd (LInt 7) "x" 79 | 80 | eval idF $ Assert idF $ TInt :-> TInt 81 | 82 | 83 | let getMethod m c t = 84 | (V $ VName $ "@" <> m) :@ V (VName $ getDict $ IsInst c t) 85 | let apps :: [(Bool, Bool)] = do 86 | a <- [False, True] 87 | b <- [False, True] 88 | pure (a, b) 89 | for_ apps $ \(a, b) -> 90 | evalDicts (bool "False" "True" $ a == b) $ 91 | "==" 92 | :@ bool "False" "True" a 93 | :@ bool "False" "True" b 94 | 95 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/TypeCheckingSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module TypeCheckingSpec where 5 | 6 | import Data.Monoid ((<>)) 7 | import StdLib 8 | import Test.Hspec 9 | import TypeChecking 10 | import Types 11 | import Utils 12 | 13 | fromRight (Right a) = a 14 | 15 | 16 | typeCheck :: Exp VName -> Qual Type -> SpecWith () 17 | typeCheck e t = it (show t) $ test' e `shouldBe` Right t 18 | 19 | 20 | typeError :: Exp VName -> SpecWith () 21 | typeError e = it ("type error: " <> show e) $ do 22 | let Left z = test' e 23 | z `shouldContain` "types don't unify" 24 | 25 | 26 | kindError :: Type -> SpecWith () 27 | kindError t = it ("kind error: " <> show t) $ do 28 | let Left z = runTI $ kind t 29 | z `shouldContain` "kind mismatch" 30 | 31 | 32 | ambiguous :: Exp VName -> SpecWith () 33 | ambiguous e = it ("ambiguous: " <> show e) $ do 34 | let Left z = test' e 35 | z `shouldContain` "is ambiguous" 36 | 37 | 38 | spec :: Spec 39 | spec = do 40 | describe "type checking" $ do 41 | let idCT = [CCat "b"] :=> TCat "b" "a" "a" 42 | idT = [] :=> "a" :-> "a" 43 | typeCheck "id" idCT 44 | typeCheck ("id" :@ "id") idCT 45 | typeCheck (lam "x" "x") idT 46 | typeCheck (let_ "x" "id" "x") idCT 47 | typeCheck (Assert "id" $ unqualType idT) idT 48 | typeCheck (Assert "id" $ "b" :-> "b") idT 49 | 50 | typeCheck ("." :@ "Inl") $ 51 | [] :=> ("a" :-> "b") :-> "a" :-> TSum "b" "c" 52 | 53 | typeCheck "==" $ 54 | [IsInst "Eq" "a"] :=> "a" :-> "a" :-> TBool 55 | 56 | let eqIntT = TInt :-> TInt :-> TBool 57 | typeCheck (Assert "==" eqIntT) $ [] :=> eqIntT 58 | typeCheck (let_ "x" "==" $ Assert "x" eqIntT) $ [] :=> eqIntT 59 | typeCheck (let_ "x" (Assert "==" eqIntT) "x") $ [] :=> eqIntT 60 | 61 | typeCheck (lam "x" $ "==" :@ "x" :@ LInt 5) $ 62 | [] :=> TInt :-> TBool 63 | 64 | let eqAxBT = TProd "a" "b" :-> TProd "a" "b" :-> TBool 65 | typeCheck (Assert "==" eqAxBT) $ 66 | [IsInst "Eq" "a", IsInst "Eq" "b"] :=> eqAxBT 67 | 68 | typeCheck "Unit" $ [] :=> TUnit 69 | typeCheck ("Inl" :@ "Unit") $ [] :=> TSum TUnit "a" 70 | typeCheck (LInt 5) $ [] :=> TInt 71 | typeCheck (LProd "id" "id") $ 72 | [CCat "b", CCat "d"] :=> TProd (TCat "b" "a" "a") (TCat "d" "c" "c") 73 | typeCheck (LProd "==" "==") $ 74 | [IsInst "Eq" "a", IsInst "Eq" "b"] 75 | :=> TProd ("a" :-> "a" :-> TBool) ("b" :-> "b" :-> TBool) 76 | 77 | typeCheck ( 78 | case_ "Unit" 79 | [ (PWildcard, "Unit") 80 | , (PWildcard, "Unit") 81 | ] 82 | ) $ [] :=> TUnit 83 | 84 | typeCheck ( 85 | case_ "Unit" 86 | [ (PVar "x", "x") 87 | , (PWildcard, "Unit") 88 | ] 89 | ) $ [] :=> TUnit 90 | 91 | typeCheck ( 92 | lam "z" $ 93 | case_ "z" 94 | [ (PCon "Inl" [PVar "x"], "x") 95 | , (PCon "Inr" [PCon "Unit" []], "Unit") 96 | ] 97 | ) $ [] :=> TSum TUnit TUnit :-> TUnit 98 | 99 | let lamCase = 100 | lam "z" $ case_ "z" [ (PCon "Inl" [PVar "x"], "x") , (PCon "Inr" [PVar "z"], "z") ] 101 | 102 | typeCheck lamCase $ 103 | [] :=> TSum "a" "a" :-> "a" 104 | 105 | -- TODO(sandy): THERE IS A BUG HERE MY DUDE -- this gets inferred as having type `a` 106 | -- typeCheck (lamCase :@ ("Inr" :@ "Unit")) $ 107 | -- [] :=> TUnit 108 | 109 | typeCheck (LString "hello") $ [] :=> TString 110 | 111 | let getMethod m c t = 112 | (V $ VName $ "@" <> m) :@ V (VName $ getDict $ IsInst c t) 113 | 114 | typeCheck (getMethod "==" "Eq" TBool) $ 115 | [] :=> TBool :-> TBool :-> TBool 116 | typeCheck (getMethod "==" "Eq" TInt) $ 117 | [] :=> TInt :-> TInt :-> TBool 118 | 119 | typeError $ "fst" :@ "Inl" 120 | typeError $ 121 | case_ "Unit" 122 | [ (PWildcard, "Unit") 123 | , (PWildcard, LInt 5) 124 | ] 125 | typeError $ 126 | case_ "Unit" 127 | [ (PVar "x", "x") 128 | , (PWildcard, LInt 5) 129 | ] 130 | 131 | ambiguous $ "==" :@ "==" :@ "==" 132 | 133 | describe "kind checking" $ do 134 | kindError $ TInt :@@ TBool 135 | kindError $ TCon (TName "+" K2) :@@ TCon (TName "+" K2) 136 | kindError $ TCon (TName "+" K2) :@@ TInt :@@ TCon (TName "," K2) 137 | 138 | --------------------------------------------------------------------------------