├── Setup.hs ├── stack.yaml ├── .gitignore ├── src └── Fresh │ ├── Kind.hs │ ├── Module.hs │ ├── Expr.hs │ ├── OrderedSet.hs │ ├── BuiltIn.hs │ ├── CodeGen.hs │ ├── Unify.hs │ ├── Pretty.hs │ ├── InferMonad.hs │ ├── Types.hs │ └── Infer.hs ├── fresh.cabal ├── doc └── spec.md ├── Main.hs ├── LICENSE └── test └── Spec.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | resolver: lts-6.2 -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox/ 2 | cabal.sandbox.config 3 | dist/ 4 | *.i_hi 5 | *.i_o 6 | .stack-work/ 7 | -------------------------------------------------------------------------------- /src/Fresh/Kind.hs: -------------------------------------------------------------------------------- 1 | module Fresh.Kind where 2 | 3 | #ifdef QC 4 | import Test.QuickCheck 5 | #endif 6 | 7 | data Kind = Star 8 | | Composite 9 | | KArrow Kind Kind 10 | deriving (Eq, Ord, Show) 11 | 12 | app :: Kind -> Kind -> Maybe Kind 13 | app (KArrow x y) x' | x == x' = Just y 14 | app _ _ = Nothing 15 | 16 | compose :: Kind -> Kind -> Maybe Kind 17 | compose (KArrow y' z) (KArrow x y) 18 | | y' == y = Just $ KArrow x z 19 | compose _ _ = Nothing 20 | 21 | 22 | #ifdef QC 23 | 24 | instance Arbitrary Kind where 25 | arbitrary = 26 | oneof 27 | [ return Star 28 | , KArrow <$> arbitrary <*> arbitrary 29 | ] 30 | 31 | return [] 32 | runTests = $verboseCheckAll 33 | 34 | #endif 35 | 36 | -------------------------------------------------------------------------------- /src/Fresh/Module.hs: -------------------------------------------------------------------------------- 1 | module Fresh.Module where 2 | 3 | import Fresh.Types (Id, Class, ClassId, Instance) 4 | import Fresh.Expr (EVarName) 5 | 6 | 7 | import Data.Map ( Map ) 8 | 9 | import Data.Monoid ((<>)) 10 | 11 | data Module t e 12 | = Module 13 | { moduleTypes :: Map Id t 14 | , moduleExprs :: Map EVarName (e) 15 | , moduleClasses :: Map ClassId (Class t e) 16 | , moduleInstances :: [ Instance t e ] 17 | } 18 | 19 | instance Monoid (Module t e) where 20 | mempty = 21 | Module 22 | { moduleTypes = mempty 23 | , moduleExprs = mempty 24 | , moduleClasses = mempty 25 | , moduleInstances = mempty 26 | } 27 | mappend x y = 28 | Module 29 | { moduleTypes = moduleTypes x <> moduleTypes y 30 | , moduleExprs = moduleExprs x <> moduleExprs y 31 | , moduleClasses = moduleClasses x <> moduleClasses y 32 | , moduleInstances = moduleInstances x <> moduleInstances y 33 | } 34 | 35 | -------------------------------------------------------------------------------- /src/Fresh/Expr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | module Fresh.Expr where 6 | 7 | 8 | import GHC.Generics (Generic) 9 | import qualified Data.Foldable 10 | import Fresh.Types (QualType, Type, CompositeLabelName(..)) 11 | 12 | newtype ETypeAsc = ETypeAsc (QualType Type) 13 | deriving (Generic, Eq, Ord, Show) 14 | 15 | data EVarName = EVarName String 16 | deriving (Generic, Eq, Ord, Show) 17 | 18 | data Lit a 19 | = LitNum Double 20 | | LitString String 21 | | LitBool Bool 22 | | LitStruct [(CompositeLabelName, (Expr a))] 23 | deriving (Generic, Eq, Ord, Show, Functor, Foldable, Traversable) 24 | 25 | data Expr a 26 | = ELit a (Lit a) 27 | | EVar a EVarName 28 | | ELam a EVarName (Expr a) 29 | | EALam a EVarName ETypeAsc (Expr a) 30 | | EApp a (Expr a) (Expr a) 31 | | ELet a EVarName (Expr a) (Expr a) 32 | | EAsc a ETypeAsc (Expr a) 33 | | EGetField a (Expr a) CompositeLabelName 34 | | EBuiltIn a EVarName ETypeAsc 35 | deriving (Generic, Eq, Ord, Show, Functor, Foldable, Traversable) 36 | 37 | getAnnotation :: Expr a -> a 38 | getAnnotation = head . Data.Foldable.toList 39 | 40 | -- type FExpr = Fix Expr 41 | -- deriving (Generic, Eq, Ord, Show) 42 | -------------------------------------------------------------------------------- /src/Fresh/OrderedSet.hs: -------------------------------------------------------------------------------- 1 | module Fresh.OrderedSet where 2 | 3 | import qualified Data.Set as Set 4 | import Data.Set (Set) 5 | 6 | 7 | data OrderedSet a = OrderedSet { osList :: [a], osSet :: Set a } 8 | deriving (Show) 9 | 10 | instance Eq a => Eq (OrderedSet a) where 11 | o1 == o2 = osList o1 == osList o2 12 | o1 /= o2 = osList o1 /= osList o2 13 | 14 | instance Ord a => Ord (OrderedSet a) where 15 | o1 `compare` o2 = osList o1 `compare` osList o2 16 | 17 | instance Foldable OrderedSet where 18 | foldr f x (OrderedSet xs _) = foldr f x xs 19 | 20 | ordTraverse :: (Ord b, Applicative f) => (a -> f b) -> OrderedSet a -> f (OrderedSet b) 21 | ordTraverse f (OrderedSet xs _) = fromList <$> traverse f xs 22 | 23 | null :: Ord a => OrderedSet a -> Bool 24 | null (OrderedSet [] _) = True 25 | null _ = False 26 | 27 | empty :: OrderedSet a 28 | empty = OrderedSet [] Set.empty 29 | 30 | singleton :: a -> OrderedSet a 31 | singleton x = OrderedSet [x] (Set.singleton x) 32 | 33 | member :: Ord a => a -> OrderedSet a -> Bool 34 | member x (OrderedSet _ ss) = x `Set.member` ss 35 | 36 | insert :: Ord a => a -> OrderedSet a -> OrderedSet a 37 | insert x os@(OrderedSet xs ss) = if x `Set.member` ss 38 | then os 39 | else OrderedSet (x:xs) (Set.insert x ss) 40 | 41 | fromList :: Ord a => [a] -> OrderedSet a 42 | fromList = foldr insert empty 43 | 44 | toList :: OrderedSet a -> [a] 45 | toList (OrderedSet xs _) = xs 46 | 47 | toSet :: OrderedSet a -> Set a 48 | toSet (OrderedSet _ ss) = ss 49 | 50 | difference :: Ord a => OrderedSet a -> OrderedSet a -> OrderedSet a 51 | difference (OrderedSet xs sxs) (OrderedSet _ sys) = 52 | OrderedSet (filter (`Set.member` ds) xs) ds 53 | where ds = sxs `Set.difference` sys 54 | 55 | intersection :: Ord a => OrderedSet a -> OrderedSet a -> OrderedSet a 56 | intersection (OrderedSet xs sxs) (OrderedSet _ sys) = 57 | OrderedSet (filter (`Set.member` is) xs) is 58 | where is = sxs `Set.intersection` sys 59 | 60 | concatUnion :: Ord a => OrderedSet a -> OrderedSet a -> OrderedSet a 61 | concatUnion = foldr insert 62 | 63 | concatUnions :: Ord a => [OrderedSet a] -> OrderedSet a 64 | concatUnions [] = empty 65 | concatUnions (o:os) = foldr concatUnion o os 66 | -------------------------------------------------------------------------------- /fresh.cabal: -------------------------------------------------------------------------------- 1 | name: fresh 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | -- license: 6 | license-file: LICENSE 7 | author: Noam Lewis 8 | maintainer: jones.noamle@gmail.com 9 | -- copyright: 10 | -- category: 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.16 14 | 15 | flag QC 16 | description: Enable QuickCheck 17 | default: False 18 | 19 | library 20 | exposed-modules: Fresh.Expr 21 | , Fresh.BuiltIn 22 | , Fresh.CodeGen 23 | , Fresh.Kind 24 | , Fresh.Module 25 | , Fresh.Types 26 | , Fresh.Pretty 27 | , Fresh.Infer 28 | , Fresh.InferMonad 29 | , Fresh.Unify 30 | , Fresh.OrderedSet 31 | -- , Fresh.Subst 32 | -- other-modules: 33 | -- other-extensions: 34 | build-depends: base >=4.7 && <5 35 | , containers >= 0.5.6.2 36 | , either 37 | , mtl >= 2.2.1 38 | , transformers 39 | , ansi-wl-pprint 40 | hs-source-dirs: src 41 | default-language: Haskell2010 42 | ghc-options: -Wall 43 | ghc-prof-options: -threaded -rtsopts -Wall -auto-all -caf-all 44 | default-extensions: CPP 45 | if flag(QC) 46 | cpp-options: -DQC 47 | build-depends: QuickCheck >= 2.8 48 | 49 | executable fresh 50 | main-is: Main.hs 51 | ghc-options: -threaded -rtsopts -Wall 52 | ghc-prof-options: -threaded -rtsopts -Wall -auto-all -caf-all 53 | default-language: Haskell2010 54 | default-extensions: CPP 55 | build-depends: base >= 4.7 && <5 56 | , fresh 57 | , ansi-wl-pprint 58 | if flag(QC) 59 | cpp-options: -DQC 60 | 61 | 62 | test-suite fresh-test 63 | type: exitcode-stdio-1.0 64 | hs-source-dirs: test 65 | main-is: Spec.hs 66 | build-depends: QuickCheck 67 | , base 68 | , containers >= 0.5.6.2 69 | , derive 70 | , fresh 71 | , ansi-wl-pprint 72 | default-extensions: CPP 73 | ghc-options: -threaded -rtsopts -Wall 74 | default-language: Haskell2010 75 | -------------------------------------------------------------------------------- /doc/spec.md: -------------------------------------------------------------------------------- 1 | # Fresh, a programming language 2 | 3 | ** This document is a work in progress ** 4 | 5 | ## Introduction 6 | 7 | The Fresh programming language is designed for low-level, systems programming. It should be useful where C would be used. As such, it has the following properties: 8 | 9 | * Very low runtime overhead 10 | * Easy integration with existing C code 11 | * Strong, static type system, with type inference 12 | 13 | Which lead to the following choices: 14 | 15 | * Manual memory management (with some static safety) 16 | * Generate human-readable C code (to allow additional manual or automatic verification of compilation output) 17 | 18 | ## Type System 19 | 20 | Fresh's type system includes: 21 | 22 | * Type inference 23 | * Generics (including rank-n types) 24 | * Type classes 25 | * Polymorphic sum and product types 26 | 27 | # Type System Reference 28 | 29 | ## Fresh is based on HMF 30 | 31 | The Fresh type system is based on HMF, with added type classes and row polymorphism (for both sum and product types). HMF was chosen as the basis for Fresh, for supporting rank-n types while being relatively easy to understand & simple to implement. 32 | 33 | ## Type Inference 34 | 35 | HMF, and hence Fresh, can infer types completely, as long as they don't require rank-n polymorphism. Wherever rank-n polymorphism is used, an annotation is required. The simpleset way to ensure succesful inference is to place type annotations on all rank-n function arguments. 36 | 37 | ## Polymorphic Sum and Product Types ## 38 | 39 | *Sum types* are like tagged unions: each value must be one of a several specific forms. For example, `Maybe a` is a sum type, and all values must be either `Nothing` or have the form `Just x` (where `x` has type `a`). `Nothing` and `Just` are called *data constructors*. The type `Maybe a` has two data constructors: `Nothing` and `Just`. 40 | 41 | Some sum types have no names, and are described by their structure. For example, the type: `+{ FileNotFound | AccessDenied }` has exactly two constructors. Notice the `+{ .. }` notation: `+` stands for "sum type". 42 | 43 | *Polymorphic sum types* are types where the set of data constructors is polymorphic. For example, the type `+{ FileNotFound | AccessDenied | a }` has *at least* two constructors, `FileNotFound` and `AccessDenied`, but is compatible with types that have more than just those two. This pattern is very useful for partial error handling: 44 | 45 | ``` 46 | errorHandler err = 47 | case err of 48 | FileNotFound -> createFile ... 49 | AccessDenied -> assertionFailed "Not supposed to happen!" 50 | x -> customHandler x -- The function 'customHandler' must accept all other constructors not handled here. 51 | ``` 52 | 53 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | -- import Test.QuickCheck 5 | -- import Data.DeriveTH 6 | 7 | import Control.Monad (forM_) 8 | import Data.String (IsString(..)) 9 | import Fresh.Pretty () 10 | import Fresh.Kind (Kind(..)) 11 | import Fresh.Types (QualType(..), Type, Fix(..), TypeAST(..), TCon(..), Id(..), Pred(..)) 12 | import Fresh.Expr (EVarName(..), Lit(..), Expr(..), getAnnotation) 13 | import Fresh.Infer (inferExpr) 14 | 15 | import Text.PrettyPrint.ANSI.Leijen (Pretty(..)) 16 | 17 | instance IsString EVarName where 18 | fromString = EVarName 19 | 20 | 21 | -- Example: 22 | 23 | let_ :: EVarName -> Expr () -> Expr () -> Expr () 24 | let_ = ELet () 25 | 26 | var :: EVarName -> Expr () 27 | var = EVar () 28 | 29 | num :: Double -> Expr () 30 | num = ELit () . LitNum 31 | 32 | (~$) :: Expr () -> Expr () -> Expr () 33 | (~$) = EApp () 34 | 35 | -- (~::) :: Expr () -> QualType Type -> Expr () 36 | -- (~::) = flip $ EAsc () 37 | 38 | (~>) :: EVarName -> Expr () -> Expr () 39 | (~>) = ELam () 40 | 41 | tcon :: String -> Type 42 | tcon x = Fix $ TyCon $ TCon (Id x) Star 43 | 44 | _Bool :: Type 45 | _Bool = tcon "Bool" 46 | 47 | _Number :: Type 48 | _Number = tcon "Number" 49 | 50 | (~=>) :: [Pred t] -> t -> QualType t 51 | (~=>) = QualType 52 | 53 | wrapFooLet :: Expr () -> Expr () 54 | wrapFooLet x = let_ "foo" x $ var "foo" 55 | 56 | exampleApIdNum = "x" ~> var "x" ~$ num 2 57 | 58 | examples = [ exampleApIdNum 59 | -- , exampleApIdNum ~:: ([] ~=> _Bool) 60 | -- , exampleApIdNum ~:: ([] ~=> _Number) 61 | , let_ "x" (num 3) $ var "x" 62 | , let_ "id" ("x" ~> var "x") $ var "id" 63 | , wrapFooLet ("y" ~> let_ "id" ("x" ~> var "y") (var "id")) 64 | , wrapFooLet ("y" ~> ("x" ~> var "y")) 65 | ] 66 | 67 | -- ---------------------------------------------------------------------- 68 | 69 | -- instance Arbitrary (t (Fix t)) => Arbitrary (Fix t) where 70 | -- arbitrary = Fix <$> arbitrary 71 | 72 | -- derive makeArbitrary ''GenVar 73 | -- derive makeArbitrary ''Id 74 | -- derive makeArbitrary ''Kind 75 | -- derive makeArbitrary ''TCon 76 | -- derive makeArbitrary ''TypeAST 77 | -- derive makeArbitrary ''Pred 78 | -- derive makeArbitrary ''QualType 79 | -- derive makeArbitrary ''Class 80 | 81 | -- derive makeArbitrary ''Lit 82 | -- derive makeArbitrary ''EVarName 83 | -- derive makeArbitrary ''Expr 84 | 85 | -- prop_constExpand :: Expr () -> Bool 86 | -- prop_constExpand expr = inferExpr expr == inferExpr (("x" ~> expr) ~$ num 0) 87 | 88 | -- return [] 89 | 90 | -- runTests :: IO Bool 91 | -- runTests = $verboseCheckAll 92 | 93 | main :: IO () 94 | main = 95 | forM_ examples $ \x -> do 96 | print $ pretty x 97 | print . pretty $ getAnnotation <$> inferExpr x 98 | -- void runTests 99 | 100 | 101 | -- {-# LANGUAGE CPP #-} 102 | -- module Main where 103 | 104 | -- import qualified Fresh.Kind as Kind 105 | 106 | -- #ifdef QC 107 | 108 | -- main = do 109 | -- putStrLn "Running tests." 110 | -- Kind.runTests 111 | 112 | -- #else 113 | 114 | -- main = do 115 | -- return () 116 | 117 | -- #endif 118 | -------------------------------------------------------------------------------- /src/Fresh/BuiltIn.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Fresh.BuiltIn where 3 | 4 | import Fresh.Types 5 | import Fresh.Module (Module(..)) 6 | import Fresh.Expr (Expr(..), EVarName(..), ETypeAsc(..)) 7 | import Fresh.Kind (Kind(..)) 8 | 9 | import qualified Data.Map as Map 10 | 11 | 12 | tcon :: String -> Type 13 | tcon x = Fix $ TyCon $ TCon (Id x) Star 14 | 15 | _String :: Type 16 | _String = tcon "String" 17 | 18 | _Number :: Type 19 | _Number = tcon "Number" 20 | 21 | _Bool :: Type 22 | _Bool = tcon "Bool" 23 | 24 | _Int :: Type 25 | _Int = tcon "Int" 26 | 27 | _Func :: Type 28 | _Func = Fix tyFunc 29 | 30 | (~=>) :: [Pred t] -> t -> QualType t 31 | (~=>) = QualType 32 | 33 | (^$) :: Type -> Type -> Type 34 | f ^$ x = Fix $ TyAp f x 35 | 36 | infixr 5 ^-> 37 | (^->) :: Type -> Type -> Type 38 | targ ^-> tres = Fix $ TyAp (Fix $ TyAp _Func targ) tres 39 | 40 | ---------------------------------------------------------------------- 41 | 42 | gv0 :: GenVar () 43 | gv0 = GenVar { genVarId = 0 44 | , genVarKind = Star 45 | , genVarAnnot = () } 46 | 47 | genericBinOp :: QualType Type 48 | genericBinOp = QualType [] (a ^-> a ^-> a) 49 | where a = Fix $ TyGenVar gv0 50 | 51 | -- Classes 52 | 53 | numClass :: Class Type (Expr ()) 54 | numClass 55 | = Class 56 | { clsId = ClassId "Num" 57 | , clsSupers = [] 58 | , clsParam = gv0 59 | , clsMembers = Map.fromList 60 | [ (MemberName "+", genericBinOp) 61 | , (MemberName "-", genericBinOp) 62 | , (MemberName "*", genericBinOp) 63 | , (MemberName "/", genericBinOp) 64 | ] 65 | , clsInstances = [intNumInstance] 66 | } 67 | 68 | 69 | ---------------------------------------------------------------------- 70 | 71 | binaryOp :: Type -> QualType Type 72 | binaryOp t = QualType [] $ t ^-> t ^-> t 73 | 74 | ebinOp :: Type -> String -> (EVarName, Expr ()) 75 | ebinOp t name = (vname, EBuiltIn () vname (ETypeAsc $ binaryOp t)) 76 | where vname = (EVarName $ "#int" ++ name) 77 | 78 | intBinOp :: String -> (EVarName, Expr ()) 79 | intBinOp = ebinOp _Int 80 | 81 | intPlus, intMinus, intMul, intDiv :: (EVarName, Expr()) 82 | intPlus = intBinOp "+" 83 | intMinus = intBinOp "-" 84 | intMul = intBinOp "*" 85 | intDiv = intBinOp "/" 86 | 87 | intNumInstance :: Instance Type (Expr ()) 88 | intNumInstance = Instance (ClassId "Num") (QualType [] _Int) m 89 | where m = Map.fromList 90 | [ (MemberName "+", snd intPlus) 91 | , (MemberName "-", snd intMinus) 92 | , (MemberName "*", snd intMinus) 93 | , (MemberName "/", snd intMinus) 94 | ] 95 | 96 | intBuiltIn :: Module Type (Expr ()) 97 | intBuiltIn 98 | = Module 99 | { moduleTypes = Map.fromList 100 | [ (Id "Int", _Int) 101 | ] 102 | , moduleExprs = Map.fromList 103 | [ intPlus 104 | , intMinus 105 | , intMul 106 | , intDiv 107 | ] 108 | , moduleClasses = Map.empty 109 | , moduleInstances = [] 110 | } 111 | ---------------------------------------------------------------------- 112 | 113 | boolBinOp :: String -> (EVarName, Expr ()) 114 | boolBinOp = ebinOp _Bool 115 | 116 | boolBuiltIn :: Module Type (Expr ()) 117 | boolBuiltIn 118 | = Module 119 | { moduleTypes = Map.fromList 120 | [ (Id "Bool", _Bool) 121 | ] 122 | , moduleExprs = Map.fromList 123 | [ boolBinOp "&&" 124 | , boolBinOp "||" 125 | ] 126 | , moduleClasses = Map.empty 127 | , moduleInstances = [] 128 | } 129 | 130 | ---------------------------------------------------------------------- 131 | 132 | builtIns :: Module Type (Expr ()) 133 | builtIns = mconcat [boolBuiltIn, intBuiltIn] 134 | -------------------------------------------------------------------------------- /src/Fresh/CodeGen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Fresh.CodeGen where 3 | 4 | import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) 5 | 6 | import Fresh.Expr 7 | import Fresh.InferMonad (callFrame) 8 | import Fresh.Infer (matchFun', runInfer) 9 | import Fresh.Types (unresolveQual, Type, QualType(..), TypeError(..) 10 | ,CompositeLabelName(..), TypeError, Fix(..), TypeAST(..)) 11 | import Fresh.InferMonad (resolve, purify) 12 | 13 | import Control.Monad.Identity (Identity, runIdentity) 14 | 15 | 16 | import Control.Monad.Trans.State (StateT(..), get, put) 17 | -- import Control.Monad.State.Class (MonadState(..), modify) 18 | -- import Control.Monad.Trans.Either (EitherT(..)) 19 | -- import Control.Monad.Error.Class (MonadError(..)) 20 | 21 | import qualified Data.Map as Map 22 | 23 | 24 | 25 | generateLit :: Lit a -> Doc 26 | generateLit (LitNum d) = pretty $ show d 27 | generateLit (LitString s) = pretty $ show s 28 | generateLit (LitBool b) = pretty . text $ if b then "true" else "false" 29 | generateLit (LitStruct []) = pretty . text $ "{}" 30 | 31 | funcArgRes :: QualType Type 32 | -> Either TypeError (QualType Type, QualType Type) 33 | funcArgRes (QualType _ (Fix (TyGen gvs q@(QualType ps _)))) = runInfer $ callFrame "funcArgRes" $ do 34 | let (QualType _ t') = unresolveQual q 35 | (targ, tres) <- matchFun' t' 36 | Just targ' <- resolve targ 37 | Just tres' <- resolve tres 38 | return (QualType ps targ', QualType ps tres') 39 | funcArgRes q@(QualType ps _) = runInfer $ callFrame "funcArgRes" $ do 40 | let (QualType _ t') = unresolveQual q 41 | (targ, tres) <- matchFun' t' 42 | Just targ' <- resolve targ 43 | Just tres' <- resolve tres 44 | return (QualType ps targ', QualType ps tres') 45 | 46 | getVars :: Expr a -> Map.Map EVarName a 47 | getVars ELit{} = Map.empty 48 | getVars (EVar a name) = Map.singleton name a 49 | getVars (ELam _ arg body) = Map.delete arg $ getVars body 50 | getVars (EALam _ arg _ body) = Map.delete arg $ getVars body 51 | getVars (EApp _ f x) = getVars f `Map.union` getVars x 52 | getVars (ELet _ name val body) = Map.delete name (getVars val `Map.union` getVars body) 53 | getVars (EAsc _ _ body) = getVars body 54 | getVars (EGetField _ row _) = getVars row 55 | getVars EBuiltIn{} = Map.empty 56 | 57 | data GenerateState 58 | = GenerateState 59 | { gsDefs :: Doc 60 | , gsCounter :: Int 61 | } 62 | 63 | generateStateEmpty :: GenerateState 64 | generateStateEmpty = GenerateState { gsDefs = empty, gsCounter = 0 } 65 | 66 | type GenerateT m a = StateT GenerateState m a 67 | 68 | type Generate a = GenerateT Identity a 69 | 70 | formatGenerateState :: Doc -> GenerateState -> Doc 71 | formatGenerateState d (GenerateState defs _) = defs <> linebreak <> d 72 | 73 | runGenerate :: Generate Doc -> Doc 74 | runGenerate x = uncurry formatGenerateState . runIdentity $ runStateT x generateStateEmpty 75 | 76 | genName :: Doc -> Generate Doc 77 | genName name = do 78 | s <- get 79 | let s' = s { gsCounter = gsCounter s + 1 } 80 | put s' 81 | return $ name <> pretty (gsCounter s) 82 | 83 | genToContext :: Generate Doc -> Generate Doc 84 | genToContext g = do 85 | d <- g 86 | s <- get 87 | put $ s { gsDefs = gsDefs s <> linebreak <> d 88 | , gsCounter = gsCounter s 89 | } 90 | return empty 91 | 92 | generateType :: QualType Type -> Generate Doc 93 | generateType q = case funcArgRes q of 94 | Left{} -> return $ pretty q 95 | Right (targ, tres) -> do 96 | tName <- genName "Func" 97 | gtres <- generateType tres 98 | gtarg <- generateType targ 99 | genToContext $ return $ "typedef" <+> gtres <+> tName <> parens gtarg <> ";" 100 | return tName 101 | 102 | generateFunDef :: Doc -> QualType Type -> EVarName -> Expr (QualType Type) -> Generate Doc 103 | generateFunDef name t arg body = genToContext $ do 104 | gtres <- generateType tres 105 | gbody <- generate body 106 | argDef <- (<+> pretty arg) <$> generateType targ 107 | closureArgsDef <- mapM (\(cName, cType) -> ( <+> pretty cName) <$> generateType cType) $ Map.toList vars 108 | let allArgsDef = (argDef : closureArgsDef) 109 | return $ vsep 110 | [ gtres <+> name <> tupled allArgsDef 111 | , "{" 112 | , indent 4 $ "return" <+> (hang 4 gbody) <> ";" 113 | , "}" 114 | ] 115 | where 116 | (targ, tres) = 117 | case funcArgRes t of 118 | Right (a,b) -> (a,b) 119 | Left x -> error ("In: " ++ show name ++ ": " ++ (show $ pretty x)) 120 | vars = Map.delete arg $ getVars body 121 | 122 | generateFun :: Doc -> QualType Type -> EVarName 123 | -> Expr (QualType Type) 124 | -> Generate Doc 125 | generateFun name t arg body = do 126 | fName <- genName name 127 | generateFunDef fName t arg body 128 | return $ pretty fName 129 | 130 | generateDef :: EVarName -> Expr (QualType Type) -> Generate Doc 131 | generateDef (EVarName s) val = do 132 | gt <- generateType $ getAnnotation val 133 | gs <- generate val 134 | return $ gt <+> pretty s <+> "=" <+> gs <> ";" 135 | 136 | generate :: Expr (QualType Type) -> Generate Doc 137 | generate (ELit _ l) = return $ generateLit l 138 | generate (EVar _ (EVarName s)) = return $ pretty s 139 | generate (ELam t arg body) = generateFun "lambda" t arg body 140 | generate (EALam t arg _tasc body) = generateFun "lambda" t arg body 141 | generate (EApp _ fun arg) = do 142 | gfun <- generate fun 143 | garg <- generate arg 144 | return $ gfun <> "(" <> garg <> ")" 145 | generate (ELet t name val body) = do 146 | gdef <- generateDef name val 147 | gbody <- generate body 148 | return $ 149 | vsep [ "({" 150 | , indent 4 $ vsep [ gdef, gbody ] 151 | , "})" 152 | ] 153 | generate (EAsc t asc body) = generate body 154 | generate (EGetField t row (CompositeLabelName field)) = 155 | generate row >>= (\gr -> return $ "(" <> gr <> ")" <> "." <> pretty field) 156 | generate (EBuiltIn a (EVarName s) _) = return $ pretty s 157 | -------------------------------------------------------------------------------- /src/Fresh/Unify.hs: -------------------------------------------------------------------------------- 1 | module Fresh.Unify where 2 | 3 | import Control.Monad (forM_, when, void, unless) 4 | import Control.Monad.Error.Class (MonadError(..)) 5 | 6 | import qualified Data.Map as Map 7 | import Data.STRef 8 | 9 | import qualified Fresh.OrderedSet as OrderedSet 10 | 11 | import Fresh.Pretty (Pretty(..)) 12 | import Fresh.Types 13 | import Fresh.InferMonad 14 | 15 | unchain :: SType s -> Infer s (SType s) 16 | unchain t@(SType (TyVar tvar)) = do 17 | vt <- readVar tvar 18 | case vt of 19 | Unbound{} -> return t 20 | Link t' -> unchain t' 21 | unchain t = return t 22 | 23 | unify :: SType s -> SType s -> Infer s () 24 | unify t1 t2 = do 25 | k1 <- getKind t1 26 | k2 <- getKind t2 27 | when (k1 /= k2) $ throwError $ KindMismatchError k1 k2 28 | t1' <- unchain t1 29 | t2' <- unchain t2 30 | pt1 <- purify t1' 31 | pt2 <- purify t2' 32 | let wrapError :: TypeError -> Infer s () 33 | wrapError e = throwError (WrappedError (UnificationError (show $ pretty pt1) (show $ pretty pt2)) e) 34 | unify' t1' t2' `catchError` wrapError 35 | 36 | unify' :: SType s -> SType s -> Infer s () 37 | unify' (SType (TyVar tvar1)) (SType (TyVar tvar2)) = do 38 | vt1 <- readVar tvar1 39 | vt2 <- readVar tvar2 40 | case (vt1, vt2) of 41 | (Unbound _n1 l1, Unbound _n2 l2) -> 42 | if l1 < l2 43 | then writeVar tvar2 vt1 44 | else writeVar tvar1 vt2 45 | (Unbound{}, Link lt2) -> varBind tvar1 lt2 46 | (Link lt1, Unbound{}) -> varBind tvar2 lt1 47 | (Link lt1, Link lt2) -> unify' lt1 lt2 48 | 49 | unify' (SType (TyVar tvar)) t = varBind tvar t 50 | unify' t (SType (TyVar tvar)) = varBind tvar t 51 | unify' (SType (TyAST t1)) (SType (TyAST t2)) = unifyAST t1 t2 52 | 53 | unifyAST :: TypeAST Level (SType s) -> TypeAST Level (SType s) -> Infer s () 54 | unifyAST (TyAp t1 t2) (TyAp t1' t2') = do 55 | unify t1 t1' 56 | unify t2 t2' 57 | unifyAST (TyCon tc1) (TyCon tc2) | tc1 == tc2 = return () 58 | unifyAST (TyGenVar g1) (TyGenVar g2) | g1 == g2 = return () 59 | unifyAST u1@(TyGen vs1 (QualType ps1 t1)) u2@(TyGen vs2 (QualType ps2 t2)) | length vs1 == length vs2 = do 60 | -- TODO: check instance relation (subsumption) 61 | ks1 <- mapM getKind vs1 62 | ks2 <- mapM getKind vs2 63 | forM_ (zip ks1 ks2) $ \(k1, k2) -> when (k1 /= k2 ) $ throwError $ KindMismatchError k1 k2 64 | curLevel <- getCurrentLevel 65 | skolems <- mapM (\k -> GenVar <$> freshName <*> pure k <*> pure curLevel) ks1 66 | let skolemTs = map (SType . TyAST . TyGenVar) skolems 67 | t1' <- substGens vs1 skolemTs t1 68 | t2' <- substGens vs2 skolemTs t2 69 | unify t1' t2' 70 | gvs1 <- liftST $ freeGenVars u1 71 | gvs2 <- liftST $ freeGenVars u2 72 | unless (OrderedSet.null $ OrderedSet.fromList skolems `OrderedSet.intersection` (gvs1 `OrderedSet.concatUnion` gvs2) ) 73 | $ throwError 74 | $ EscapedSkolemError 75 | $ concat 76 | [ "Type not polymorphic enough to unify" 77 | , "\n\t", "Type 1: ", show u1 78 | , "\n\t", "Type 2: ", show u2 79 | ] 80 | 81 | unifyAST (TyComp CompositeTerminal) (TyComp CompositeTerminal) = return () 82 | 83 | unifyAST (TyComp c1) (TyComp c2) = do 84 | let FlatComposite labels1 mEnd1 = flattenComposite c1 85 | FlatComposite labels2 mEnd2 = flattenComposite c2 86 | common = Map.intersectionWith (,) labels1 labels2 87 | in1only = Map.difference labels1 labels2 88 | in2only = Map.difference labels2 labels1 89 | emptyRow = SType $ TyAST $ TyComp CompositeTerminal 90 | -- TODO: wrap errors to say which field failed 91 | forM_ (Map.elems common) $ uncurry unify 92 | remainderVar <- freshRVar 93 | if Map.null in1only && Map.null in2only 94 | then case (mEnd1, mEnd2) of 95 | (Nothing, Nothing) -> return () 96 | (Just e, Nothing) -> unify e emptyRow 97 | (Nothing, Just e) -> unify e emptyRow 98 | (Just e1, Just e2) -> unify e1 e2 99 | else do 100 | let remainderVarT = SType $ TyVar remainderVar 101 | unifyRemainder rem' mEnd = 102 | -- e1 + r1 = e2 + r2 103 | -- (r + r2) + r1 = (r + r1) + r2 104 | case mEnd of 105 | Nothing -> 106 | if Map.null rem' 107 | then varBind remainderVar emptyRow 108 | else traverse purify rem' >>= \pt -> throwError $ RowEndError (show $ fmap pretty pt) 109 | Just end -> 110 | unify (SType $ TyAST $ TyComp $ unflattenComposite $ FlatComposite rem' $ Just remainderVarT) end 111 | unifyRemainder in1only mEnd2 112 | unifyRemainder in2only mEnd1 113 | 114 | unifyAST t1 t2 = unifyError (SType $ TyAST t1) (SType $ TyAST t2) 115 | 116 | unifyError :: SType s -> SType s -> Infer s a 117 | unifyError t1 t2 = do 118 | pt1 <- purify t1 119 | pt2 <- purify t2 120 | throwError $ UnificationError (show $ pretty pt1) (show $ pretty pt2) 121 | 122 | 123 | varBind :: TypeVar (STRef s) (SType s) -> SType s -> Infer s () 124 | varBind tvar t = do 125 | tvarK <- getKind tvar 126 | tK <- getKind t 127 | when (tvarK /= tK) $ throwError $ KindMismatchError tvarK tK 128 | vt <- readVar tvar 129 | case vt of 130 | Link t' -> unify t' t 131 | Unbound name l1 -> --writeVar tvar (Link t) 132 | case t of 133 | (SType (TyVar tvar2)) -> do 134 | vt2 <- readVar tvar2 135 | case vt2 of 136 | Link t2 -> unify (SType $ TyVar tvar) t2 137 | Unbound _name2 l2 -> do 138 | writeVar tvar (Link t) 139 | -- adjust the lambda-rank of the unifiable variable 140 | when (l2 > l1) (writeVar tvar2 (Unbound _name2 l1)) 141 | (SType (TyAST tast)) -> do 142 | tvs <- liftST $ freeVars tast 143 | when (name `OrderedSet.member` tvs) $ do 144 | pt <- purify t 145 | throwError $ OccursError (show $ pretty vt) (show $ pretty pt) 146 | writeVar tvar (Link t) 147 | -- adjust the lambda-rank of the unifiable variables in tp2 148 | adjustLevel l1 t 149 | 150 | adjustLevel :: Level -> SType s -> Infer s () 151 | adjustLevel l (SType (TyVar tvar)) = do 152 | tv <- readVar tvar 153 | case tv of 154 | Link t -> adjustLevel l t 155 | Unbound name l' -> when (l' > l) (writeVar tvar (Unbound name l)) 156 | adjustLevel l (SType (TyAST t)) = void $ traverse (adjustLevel l) t 157 | -------------------------------------------------------------------------------- /src/Fresh/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | module Fresh.Pretty 7 | ( Pretty(..) ) 8 | where 9 | 10 | import Data.STRef (STRef) 11 | import Text.PrettyPrint.ANSI.Leijen 12 | import Fresh.Types 13 | import Fresh.Kind (Kind(..)) 14 | import Fresh.Expr 15 | 16 | import qualified Data.Map as Map 17 | 18 | numToLetter :: Int -> Doc 19 | numToLetter idx = 20 | if idx < length ['a'..'z'] 21 | then char $ ['a'..'z'] !! idx 22 | else "t" <> int idx 23 | 24 | instance Pretty TCon where 25 | pretty (TCon (Id s) _) = pretty s 26 | 27 | instance Pretty Kind where 28 | pretty (KArrow k1 k2) = pretty k1 <+> "->" <+> pretty k2 29 | pretty Star = "*" 30 | pretty Composite = "@" 31 | 32 | class LevelPretty l where 33 | levelPretty :: l -> Doc 34 | 35 | instance LevelPretty () where 36 | levelPretty = const empty 37 | 38 | instance LevelPretty Level where 39 | -- pretty _ = empty 40 | levelPretty LevelAny = "^^" 41 | levelPretty (Level x) = "^" <> pretty x 42 | 43 | instance LevelPretty g => Pretty (GenVar g) where 44 | pretty (GenVar idx k l) = pk name <> levelPretty l 45 | where name = numToLetter idx 46 | pk = if k == Star 47 | then id 48 | else \x -> x <+> "::" <+> pretty k 49 | 50 | instance Pretty CompositeLabelName where 51 | pretty (CompositeLabelName x) = dquotes $ pretty x 52 | 53 | instance Pretty t => Pretty (Composite t) where 54 | pretty (CompositeLabel name t c) = 55 | pretty name <> ":" <+> pretty t <> rest 56 | where rest = case c of 57 | CompositeLabel{} -> comma <+> pretty c 58 | _ -> pretty c 59 | -- TODO trailing comma 60 | pretty CompositeTerminal = empty 61 | pretty (CompositeRemainder t) = " |" <+> pretty t 62 | 63 | instance (LevelPretty g, HasKind t, Pretty t) => Pretty (TypeAST g t) where 64 | pretty (TyAp fun arg) = 65 | case kind fun of 66 | Just (KArrow _ KArrow{}) -> pretty arg <+> pretty fun 67 | -- TODO red for bad kind app 68 | _ -> parens $ pretty fun <+> pretty arg 69 | pretty (TyCon con) = pretty con 70 | pretty (TyGenVar genVar) = pretty genVar 71 | pretty (TyGen genVar t) = parens $ "forall" <+> foldr ((<+>) . pretty) empty genVar <> "." <+> pretty t 72 | -- TODO 73 | pretty (TyComp c) = "{" <+> pretty c <+> "}" 74 | 75 | instance Pretty EVarName where 76 | pretty (EVarName s) = text s 77 | 78 | instance Pretty (Lit a) where 79 | pretty (LitNum x) = pretty x 80 | pretty (LitString x) = dquotes $ pretty x 81 | pretty (LitBool x) = pretty x 82 | pretty (LitStruct fs) = "{" <+> (vsep $ map (\(fname, fexpr) -> pretty fname <+> "=" <+> pretty fexpr) fs) <+> "}" 83 | 84 | instance Pretty ETypeAsc where 85 | pretty (ETypeAsc t) = pretty t 86 | 87 | instance Pretty (Expr a) where 88 | pretty (ELit _a l) = pretty l 89 | pretty (EVar _a varName) = pretty varName 90 | pretty (ELam _a varName e) = parens $ "\\" <> pretty varName <+> "->" <+> pretty e 91 | pretty (EALam _a varName t e) = parens $ "\\" <> parens (pretty varName <+> "::" <+> pretty t) <+> "->" <+> pretty e 92 | pretty (EApp _a e1 e2) = pretty e1 <+> pretty e2 93 | pretty (ELet _a varName def expr) = "let" <+> pretty varName <+> "=" <+> pretty def <+> "in" <+> pretty expr 94 | pretty (EAsc _a t e) = parens $ pretty e <+> "::" <+> pretty t 95 | pretty (EGetField _a e name) = pretty e <> "#" <> pretty name 96 | pretty (EBuiltIn _a name t) = parens $ pretty name <+> "::" <+> pretty t 97 | 98 | instance Pretty (f (Fix f)) => Pretty (Fix f) where 99 | pretty (Fix f) = pretty f 100 | 101 | instance Pretty ClassId where 102 | pretty (ClassId name) = pretty name 103 | 104 | instance Pretty MemberName where 105 | pretty (MemberName m) = pretty m 106 | 107 | instance (Pretty t, Pretty e) => Pretty (Class t e) where 108 | pretty cls = 109 | vsep 110 | [ "Class" 111 | <+> pretty (map (\sup -> pretty sup <+> pretty (clsParam cls)) (clsSupers cls)) 112 | <+> "=>" 113 | <+> pretty (clsId cls) <+> pretty (clsParam cls) 114 | <+> "where" 115 | , indent 4 $ vsep $ map (\(mem, t) -> pretty mem <+> "::" <+> pretty t) $ Map.toList (clsMembers cls) 116 | , vsep $ map pretty (clsInstances cls) 117 | ] 118 | 119 | instance (Pretty t, Pretty e) => Pretty (Instance t e) where 120 | pretty (Instance cid t mems) = 121 | vsep 122 | [ "instance" <+> pretty cid <+> pretty t <+> "where" 123 | , indent 4 $ vsep $ map (\(mname, mt) -> pretty mname <+> "=" <+> pretty mt) $ Map.toList mems 124 | ] 125 | 126 | instance Pretty t => Pretty (Pred t) where 127 | pretty (PredIs c t) = pretty c <+> pretty t 128 | pretty (PredNoLabel c t) = pretty t <> "/" <> pretty c 129 | 130 | instance (Pretty t) => Pretty (TVarLink t) where 131 | pretty (Unbound n l) = numToLetter n <> "'" -- " pretty n <> "," <+> "level:" <+> pretty l <> ">" 132 | pretty (Link t) = "=" <> pretty t 133 | 134 | instance (Pretty (v (TVarLink t))) => Pretty (TypeVar v t) where 135 | pretty (TypeVar cell k) = parens $ pretty cell <+> "::" <+> pretty k 136 | 137 | instance (LevelPretty g, HasKind t, Pretty (v (TVarLink t)), Pretty t) => Pretty (TypeABT g v t) where 138 | pretty (TyVar v) = pretty v 139 | pretty (TyAST t) = pretty t 140 | 141 | instance Pretty (STRef s a) where 142 | pretty _ = "" 143 | 144 | instance Pretty (SType s) where 145 | pretty (SType t) = pretty t 146 | 147 | instance Pretty PType where 148 | pretty (PType t) = pretty t 149 | 150 | instance Pretty a => Pretty (PCell a) where 151 | pretty (PCell x) = pretty x 152 | 153 | instance Pretty t => Pretty (QualType t) where 154 | pretty (QualType [] t) = pretty t 155 | pretty (QualType ps t) = pretty ps <+> "=>" <+> pretty t 156 | 157 | instance (Pretty e, Pretty a) => Pretty (Either e a) where 158 | pretty (Left e) = "Error:" <+> pretty e 159 | pretty (Right a) = pretty a 160 | 161 | instance Pretty TypeError where 162 | pretty (WrappedError eOuter eInner) = align $ vsep [pretty eOuter, "in", pretty eInner] 163 | pretty (ResolveError s) = "Error while resolving:" <+> pretty s 164 | pretty (UnificationError a b) = "Failed unifying:" <+> align (vsep [pretty a, "with", pretty b]) 165 | pretty (RowEndError x) = "Trailing row remainder:" <+> pretty x 166 | pretty (InferenceError x) = "Failed inferring a type for expression:" <+> pretty x 167 | pretty (EscapedSkolemError x) = "Skolem escaped:" <+> pretty x 168 | pretty InvalidKind = "Invalid kind" 169 | pretty (KindMismatchError k1 k2) = "Kinds mismatch error:" <+> align (vsep [pretty k1, pretty k2]) 170 | pretty (InvalidVarError x) = "Unknown variable:" <+> pretty x 171 | pretty (ExpectedFunction x) = "Expected function type, got:" <+> pretty x 172 | pretty (SubsumeError t1 t2) = "Subsuming" <+> text t1 <+> "into" <+> text t2 173 | pretty (OccursError t1 t2) = "Occurs check failed, " <+> text t1 <+> " is in " <+> text t2 174 | pretty (AssertionError s) = "ASSERTION FAILED:" <+> text s 175 | pretty (MultipleErrors es) = "Errors:" <+> align (vsep $ map pretty es) 176 | pretty (InstanceMethodMissing s) = "Instance method missing:" <+> pretty s 177 | pretty (InstanceMemberWrongType s) = "Instance member wrong type:" <+> pretty s 178 | pretty (CallFrame s) = "Frame:" <+> pretty s 179 | -------------------------------------------------------------------------------- /src/Fresh/InferMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Fresh.InferMonad where 3 | 4 | import Control.Monad (when, foldM, forM) 5 | 6 | import Data.Map (Map) 7 | import qualified Data.Set as Set 8 | import Data.STRef 9 | import Control.Monad.Trans.Class (lift) 10 | import Control.Monad.Trans.State (StateT(..)) 11 | import Control.Monad.State.Class (MonadState(..), modify) 12 | import Control.Monad.Trans.Either (EitherT(..)) 13 | import Control.Monad.Error.Class (MonadError(..)) 14 | 15 | import qualified Data.List as List 16 | import Control.Monad.ST (ST) 17 | import Data.Maybe (catMaybes, fromMaybe) 18 | 19 | import qualified Fresh.OrderedSet as OrderedSet 20 | 21 | import Fresh.Pretty (Pretty(..)) 22 | import Fresh.Types 23 | import Fresh.Expr 24 | import Fresh.Kind 25 | 26 | data InferState s 27 | = InferState 28 | { isContext :: Map EVarName (TypeVar (STRef s) (SType s)) 29 | , isGenFresh :: Int 30 | , isLevel :: Level 31 | } 32 | deriving Show 33 | 34 | type Infer s a = StateT (InferState s) (EitherT TypeError (ST s)) a 35 | 36 | getCurrentLevel :: Infer s Level 37 | getCurrentLevel = isLevel <$> get 38 | 39 | enterLevel :: Infer s () 40 | enterLevel = modify (\is -> is { isLevel = levelInc $ isLevel is }) 41 | 42 | leaveLevel :: Infer s () 43 | leaveLevel = modify (\is -> is { isLevel = levelDec $ isLevel is }) 44 | 45 | inLevel :: Infer s a -> Infer s a 46 | inLevel act = do 47 | enterLevel 48 | res <- act 49 | leaveLevel 50 | return res 51 | 52 | listUnion :: Ord a => [a] -> [a] -> [a] 53 | [] `listUnion` y = y 54 | x `listUnion` [] = x 55 | x `listUnion` y = OrderedSet.toList $ OrderedSet.fromList x `OrderedSet.concatUnion` OrderedSet.fromList y 56 | 57 | freshName :: Infer s Int 58 | freshName = do 59 | is <- get 60 | let genId = isGenFresh is 61 | put $ is { isGenFresh = genId + 1 } 62 | return genId 63 | 64 | -- TODO should return a set 65 | getUnbound :: Maybe Level -> SType s -> Infer s [TypeVar (STRef s) (SType s)] 66 | getUnbound mCurLevel (SType (TyVar tv)) = do 67 | v <- readVar tv 68 | case v of 69 | Unbound _ l -> case mCurLevel of 70 | Just curLevel | curLevel >= l -> pure [] 71 | _ -> pure [tv] 72 | Link t' -> getUnbound mCurLevel t' 73 | getUnbound mCurLevel (SType (TyAST t)) = 74 | concat <$> traverse (getUnbound mCurLevel) t 75 | 76 | mkGen :: [GenVar Level] -> [Pred (SType s)] -> SType s -> Infer s (SType s) 77 | mkGen gvs ps (SType (TyAST (TyGen gvs' (QualType ps2 t)))) = mkGen (gvs++gvs') (ps++ps2) t 78 | -- mkGen gvs ps touter@(SType (TyAST (TyAp t1@(SType (TyAST (TyAp (SType (TyAST (TyCon f))) arg))) (SType (TyAST (TyGen gvs' (QualType ps' t))))))) 79 | -- = do gvsArg <- liftST $ freeGenVars arg 80 | -- if (f == conFunc) && (OrderedSet.null $ gvsArg `OrderedSet.intersection` (OrderedSet.fromList gvs')) 81 | -- then mkGen (gvs++gvs') (ps++ps') (SType . TyAST $ TyAp t1 t) 82 | -- else return touter 83 | --mkGen gvs ps (SType (TyAST (TyAp t1 (SType (TyAST (TyGen gvs' (QualType ps2 t))))))) = mkGen (gvs++gvs') (ps++ps2) (SType (TyAST (TyAp t1 t))) 84 | mkGen [] [] t = return t 85 | mkGen gvs ps t = do 86 | freeGVs <-liftST $ freeGenVars (QualType ps t) 87 | when (not $ Set.fromList gvs `Set.isSubsetOf` OrderedSet.toSet freeGVs) $ 88 | throwError $ AssertionError $ "Non-existing GenVars appears in TyGen?! " ++ show gvs ++ " in type " ++ show t ++ ", freeGVs: " ++ show freeGVs 89 | return $ SType (TyAST (TyGen (OrderedSet.toList freeGVs) (QualType ps t))) 90 | 91 | mkGenQ :: [GenVar Level] -> [Pred (SType s)] -> SType s -> Infer s (QualType (SType s)) 92 | mkGenQ gvs ps t = do 93 | let gvsSet = OrderedSet.fromList gvs 94 | (psNotInT, psInT) <- partitionM 95 | (\p -> do gvsInP <- liftST (freeGenVars p) 96 | return $ OrderedSet.null $ gvsInP `OrderedSet.intersection` gvsSet) 97 | ps 98 | QualType psNotInT <$> mkGen gvs psInT t 99 | 100 | generalizeAtLevel :: [Pred (SType s)] -> SType s -> Maybe Level -> Infer s (QualType (SType s)) 101 | generalizeAtLevel ps t mCurLevel = do 102 | unboundTVarsT <- getUnbound mCurLevel t 103 | unboundTVarsPS <- concatMap fromPred <$> mapM (traverse $ getUnbound mCurLevel) ps 104 | let unboundTVars = unboundTVarsT ++ unboundTVarsPS 105 | let wrapGen tv@(TypeVar _ k) = do 106 | res <- readVar tv 107 | case res of 108 | Link (SType (TyAST (TyGenVar _))) -> return Nothing -- already overwritten 109 | Link _ -> error "Assertion failed" 110 | Unbound{} -> do 111 | gv <- GenVar <$> freshName <*> pure k <*> pure (fromMaybe LevelAny mCurLevel) 112 | writeVar tv (Link $ SType $ TyAST $ TyGenVar gv) 113 | return $ Just gv 114 | gvs <- catMaybes <$> mapM wrapGen unboundTVars 115 | mkGenQ gvs ps t 116 | 117 | generalize :: [Pred (SType s)] -> SType s -> Infer s (QualType (SType s)) 118 | generalize ps t = callFrame "generalize" $ getCurrentLevel >>= (generalizeAtLevel ps t . Just) 119 | 120 | instantiate :: SType s -> Infer s (QualType (SType s)) 121 | instantiate (SType (TyAST (TyGen gvs (QualType ps tGen)))) = callFrame "instantiate" $ do 122 | newGVs <- mapM (\(GenVar n k l) -> SType . TyVar <$> freshTVarK k) gvs 123 | let s = substGens gvs newGVs 124 | QualType <$> (mapM (traverse s) ps) <*> s tGen 125 | instantiate t@(SType (TyAST _)) = return $ QualType [] t 126 | instantiate t@(SType (TyVar tvar)) = do 127 | t' <- readVar tvar 128 | case t' of 129 | Unbound{} -> return $ QualType [] t -- TODO: Keep predicates on metavars? 130 | Link tLink -> instantiate tLink 131 | 132 | substGen :: GenVar Level -> SType s -> SType s -> Infer s (SType s) 133 | substGen gv tv t@(SType (TyVar tv')) = do 134 | t' <- readVar tv' 135 | case t' of 136 | Unbound{} -> return t 137 | Link tLink -> substGen gv tv tLink 138 | substGen gv tv t@(SType (TyAST tast)) = 139 | case tast of 140 | TyGenVar g -> return $ if g == gv then tv else t 141 | TyAp tf tx -> SType . TyAST <$> (TyAp <$> substGen gv tv tf <*> substGen gv tv tx) 142 | TyCon c -> return . SType . TyAST $ TyCon c 143 | TyGen gvs (QualType ps tGen') -> do 144 | let (shadowedGVs, rest) = List.partition (\sgv -> genVarId sgv == genVarId gv) gvs 145 | (newGVs, newTypes) <- 146 | unzip <$> forM shadowedGVs (\sgv -> do 147 | name <- freshName 148 | let sgv' = sgv { genVarId = name } 149 | return (sgv', SType . TyAST . TyGenVar $ sgv')) 150 | 151 | stGen' <- substGens shadowedGVs newTypes tGen' 152 | ps' <- mapM (traverse $ substGens shadowedGVs newTypes) ps 153 | mkGen (newGVs ++ rest) ps' stGen' 154 | TyComp c -> SType . TyAST . TyComp <$> traverse (substGen gv tv) c 155 | 156 | substGens :: [GenVar Level] -> [SType s] -> SType s -> Infer s (SType s) 157 | substGens vs ts t = foldM (\t' (v,s) -> substGen v s t') t $ zip vs ts 158 | 159 | fresh :: Infer s (STRef s (TVarLink t)) 160 | fresh = do 161 | curLevel <- getCurrentLevel 162 | name <- freshName 163 | lift . lift $ newSTRef $ Unbound name curLevel 164 | 165 | freshTVarK :: Kind -> Infer s (TypeVar (STRef s) a) 166 | freshTVarK k = do 167 | ref <- fresh 168 | return $ TypeVar ref k 169 | 170 | freshTVar :: Infer s (TypeVar (STRef s) a) 171 | freshTVar = freshTVarK Star 172 | 173 | freshRVar :: Infer s (TypeVar (STRef s) a) 174 | freshRVar = freshTVarK Composite 175 | 176 | 177 | liftST :: ST s a -> Infer s a 178 | liftST = lift . lift 179 | 180 | readVar :: TypeVar (STRef s) t -> Infer s (TVarLink t) 181 | readVar (TypeVar ref _) = liftST $ readSTRef ref 182 | 183 | writeVar :: TypeVar (STRef s) t -> TVarLink t -> Infer s () 184 | writeVar (TypeVar ref _) link = liftST $ writeSTRef ref link 185 | 186 | purifyVar :: TypeVar (STRef s) (SType s) -> Infer s PType 187 | purifyVar tvar@(TypeVar _ k) = do 188 | link <- readVar tvar 189 | case link of 190 | Unbound name l -> return . PType . TyVar $ TypeVar (PCell $ Unbound name l) k 191 | Link t -> purify t 192 | 193 | purify :: SType s -> Infer s PType 194 | purify (SType (TyVar tvar)) = purifyVar tvar 195 | purify (SType (TyAST t)) = PType . TyAST <$> traverse purify t 196 | 197 | resolve :: SType s -> Infer s (Maybe Type) 198 | resolve t@(SType (TyVar tvar)) = callFrame "resolve" $ do 199 | link <- readVar tvar 200 | case link of 201 | Unbound _name l -> do 202 | pt <- purify t 203 | throwError 204 | $ EscapedSkolemError $ "resolve " ++ show (pretty pt) ++ ", level: " ++ show l 205 | Link t' -> resolve t' 206 | resolve (SType (TyAST t)) = do 207 | mt <- traverse resolve t 208 | return $ fmap Fix $ sequenceA $ bimapTypeAST (const ()) id mt 209 | 210 | checkKind :: Maybe Kind -> Infer s Kind 211 | checkKind Nothing = throwError InvalidKind 212 | checkKind (Just k) = return k 213 | 214 | getKind :: HasKind t => t -> Infer s Kind 215 | getKind = checkKind . kind 216 | 217 | callFrame :: MonadError TypeError m => String -> m a -> m a 218 | callFrame s act = act `catchError` (\e -> throwError $ WrappedError (CallFrame s) e) 219 | 220 | -------------------------------------------------------------------------------- /src/Fresh/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE TupleSections #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 12 | {-# OPTIONS_GHC -fno-warn-orphans #-} 13 | module Fresh.Types where 14 | 15 | import Fresh.Kind (Kind(..)) 16 | import qualified Fresh.Kind as Kind 17 | import qualified Fresh.OrderedSet as OrderedSet 18 | import Fresh.OrderedSet (OrderedSet) 19 | import Data.STRef 20 | import Control.Monad (join) 21 | import Control.Monad.ST (ST) 22 | import Data.Map (Map) 23 | import qualified Data.Map as Map 24 | import GHC.Generics (Generic) 25 | import Data.Functor.Identity (runIdentity) 26 | 27 | 28 | partitionM :: Monad m => (t -> m Bool) -> [t] -> m ([t], [t]) 29 | partitionM _ [] = return ([], []) 30 | partitionM f (x:xs) = do 31 | (y, n) <- partitionM f xs 32 | res <- f x 33 | return $ if res then (x:y, n) else (y, x:n) 34 | 35 | data Level = Level Int | LevelAny 36 | deriving (Generic, Eq, Show) 37 | 38 | instance Ord Level where 39 | (Level x) `compare` (Level y) = x `compare` y 40 | LevelAny `compare` LevelAny = EQ 41 | _ `compare` LevelAny = LT 42 | LevelAny `compare` _ = GT 43 | 44 | mapLevel :: (Int -> Int) -> Level -> Level 45 | mapLevel f (Level x) = Level (f x) 46 | mapLevel _f l = l 47 | 48 | levelInc :: Level -> Level 49 | levelInc = mapLevel (+1) 50 | levelDec :: Level -> Level 51 | levelDec = mapLevel (\x -> x - 1) -- TODO assert > 0 52 | 53 | data Id = Id String 54 | deriving (Generic, Eq, Ord, Show) 55 | 56 | data TCon = TCon { tcId :: Id, tcKind :: Kind } 57 | deriving (Generic, Eq, Ord, Show) 58 | 59 | data GenVar a 60 | = GenVar 61 | { genVarId :: Int 62 | , genVarKind :: Kind 63 | , genVarAnnot :: a 64 | } 65 | deriving (Generic, Eq, Ord, Show, Functor) 66 | 67 | genDropAnnot :: GenVar a -> GenVar () 68 | genDropAnnot gv = gv { genVarAnnot = () } 69 | 70 | newtype CompositeLabelName = CompositeLabelName String 71 | deriving (Generic, Eq, Ord, Show) 72 | 73 | data Composite t 74 | = CompositeLabel CompositeLabelName t (Composite t) 75 | | CompositeTerminal 76 | | CompositeRemainder t 77 | deriving (Generic, Eq, Ord, Show, Functor, Foldable, Traversable) 78 | 79 | data FlatComposite t 80 | = FlatComposite { fcLabels :: Map CompositeLabelName t 81 | , fcRemainder :: Maybe t } 82 | deriving (Generic, Eq, Ord, Show, Functor, Foldable, Traversable) 83 | 84 | flattenComposite :: Composite t -> FlatComposite t 85 | flattenComposite CompositeTerminal = FlatComposite Map.empty Nothing 86 | flattenComposite (CompositeRemainder t) = FlatComposite Map.empty $ Just t 87 | flattenComposite (CompositeLabel n t c) = FlatComposite (Map.insert n t m) end 88 | where 89 | (FlatComposite m end) = flattenComposite c 90 | 91 | unflattenComposite :: FlatComposite t -> Composite t 92 | unflattenComposite (FlatComposite m mRem) = 93 | foldr (\(n, t) rest -> CompositeLabel n t rest) rem' $ Map.toList m 94 | where rem' = maybe CompositeTerminal CompositeRemainder mRem 95 | 96 | ---------------------------------------------------------------------- 97 | class HasKind t where 98 | kind :: t -> Maybe Kind -- Should really be just Kind, but hard to generate arbitrary for TyAp 99 | 100 | class Monad m => HasGen m t g where 101 | -- TODO: Should return ordered set so that foralls will have the 102 | -- genvars in deterministic order for easier alpha-equivalence 103 | freeGenVars :: t -> m (OrderedSet (GenVar g)) 104 | 105 | instance (Ord g, HasGen m t g) => HasGen m [t] g where 106 | freeGenVars ft = OrderedSet.concatUnions <$> mapM freeGenVars ft 107 | 108 | ---------------------------------------------------------------------- 109 | data ClassId = ClassId String 110 | deriving (Generic, Eq, Ord, Show) 111 | 112 | data Pred t = PredIs ClassId t | PredNoLabel CompositeLabelName t 113 | deriving (Generic, Eq, Ord, Show, Functor, Foldable, Traversable) 114 | 115 | instance HasGen m t g => HasGen m (Pred t) g where 116 | freeGenVars (PredIs _ t) = freeGenVars t 117 | freeGenVars (PredNoLabel _ t) = freeGenVars t 118 | 119 | fromPred :: Pred t -> t 120 | fromPred (PredIs _ x) = x 121 | fromPred (PredNoLabel _ x) = x 122 | 123 | data QualType t = QualType { qualPred :: [Pred t], qualType :: t } 124 | deriving (Generic, Eq, Ord, Show, Functor, Foldable, Traversable) 125 | 126 | instance HasKind t => HasKind (QualType t) where 127 | kind (QualType _ t) = kind t 128 | 129 | instance (Ord g, HasGen m t g) => HasGen m (QualType t) g where 130 | freeGenVars (QualType ps t) = do 131 | gvsp <- mapM freeGenVars ps 132 | gvst <- freeGenVars t 133 | return $ OrderedSet.concatUnions (gvst:gvsp) 134 | 135 | 136 | emptyQual :: t -> QualType t 137 | emptyQual = QualType [] 138 | 139 | ---------------------------------------------------------------------- 140 | 141 | data TypeAST g t 142 | = TyAp { _tyApFun :: t, _tyApArg :: t } 143 | | TyCon { _tyCon :: TCon } 144 | | TyGenVar { _tyGenVar :: GenVar g } 145 | | TyGen { _tyGenVars :: [GenVar g], _tyGenScheme :: QualType t } 146 | | TyComp { _tyComp :: Composite t } 147 | deriving (Generic, Eq, Ord, Show, Functor, Foldable, Traversable) 148 | 149 | instance (Ord g, HasGen m t g) => HasGen m (TypeAST g t) g where 150 | freeGenVars (TyGenVar g) = pure $ OrderedSet.singleton g 151 | freeGenVars (TyGen gvs t) = OrderedSet.difference <$> freeGenVars t <*> pure (OrderedSet.fromList gvs) 152 | freeGenVars t = foldr OrderedSet.concatUnion OrderedSet.empty <$> traverse freeGenVars t 153 | 154 | class Monad m => HasVars m t where 155 | freeVars :: t -> m (OrderedSet UnboundVarName) 156 | 157 | instance HasVars m t => HasVars m (TypeAST g t) where 158 | freeVars t = foldr OrderedSet.concatUnion OrderedSet.empty <$> traverse freeVars t 159 | 160 | bimapTypeAST :: (g -> g') -> (t -> t') -> TypeAST g t -> TypeAST g' t' 161 | bimapTypeAST fg _ (TyGenVar g) = TyGenVar (fmap fg g) 162 | bimapTypeAST fg ft (TyGen gvs t) = TyGen (map (fmap fg) gvs) (fmap ft t) 163 | bimapTypeAST _ ft (TyAp t1 t2) = TyAp (ft t1) (ft t2) 164 | bimapTypeAST _ _ TyCon{..} = TyCon{..} 165 | bimapTypeAST _ ft (TyComp c) = TyComp $ fmap ft c 166 | 167 | tyRec :: TypeAST g t 168 | tyRec = TyCon (TCon (Id "Rec") (KArrow Composite Star)) 169 | 170 | tySum :: TypeAST g t 171 | tySum = TyCon (TCon (Id "Sum") (KArrow Composite Star)) 172 | 173 | conFunc :: TCon 174 | conFunc = TCon (Id "->") (KArrow Star (KArrow Star Star)) 175 | 176 | tyFunc :: TypeAST g t 177 | tyFunc = TyCon conFunc 178 | 179 | class HasLevel t where 180 | level :: t -> Level 181 | 182 | instance HasLevel Level where 183 | level = id 184 | 185 | instance HasLevel (GenVar Level) where 186 | level = genVarAnnot 187 | instance HasLevel t => HasLevel (TypeAST g t) where 188 | level = foldr (min . level) LevelAny 189 | 190 | instance HasKind TCon where 191 | kind = Just . tcKind 192 | instance HasKind (GenVar a) where 193 | kind = Just . genVarKind 194 | instance HasKind t => HasKind (TypeAST g t) where 195 | kind (TyAp f x) = join $ Kind.app <$> kind f <*> kind x 196 | kind (TyCon tc) = kind tc 197 | kind (TyGenVar gv) = kind gv 198 | kind (TyGen _gvs s) = kind s 199 | kind (TyComp _fs) = Just Composite 200 | 201 | type UnboundVarName = Int 202 | 203 | data TVarLink t 204 | = Unbound UnboundVarName Level 205 | | Link t 206 | deriving (Generic, Eq, Ord, Show, Functor) 207 | 208 | data TypeVar v t 209 | = TypeVar { tyVarCell :: v (TVarLink t), tyVarKind :: Kind } 210 | deriving (Generic, Functor) 211 | 212 | instance Show (STRef s t) where 213 | show _v = "" 214 | 215 | instance HasGen m t g => HasGen m (TVarLink t) g where 216 | freeGenVars (Link t) = freeGenVars t 217 | freeGenVars Unbound{} = pure OrderedSet.empty 218 | 219 | instance HasGen (ST s) t g => HasGen (ST s) (TypeVar (STRef s) t) g where 220 | freeGenVars (TypeVar cell _) = 221 | readSTRef cell >>= freeGenVars 222 | 223 | instance HasKind (TypeVar v t) where 224 | kind (TypeVar _ k) = Just k 225 | 226 | instance HasVars m t => HasVars m (TVarLink t) where 227 | freeVars (Link t) = freeVars t 228 | freeVars (Unbound n _) = pure (OrderedSet.singleton n) 229 | 230 | instance HasVars (ST s) t => HasVars (ST s) (TypeVar (STRef s) t) where 231 | freeVars (TypeVar cell _) = 232 | readSTRef cell >>= freeVars 233 | 234 | -- deriving instance Eq t => Eq (TypeVar Identity t) 235 | -- deriving instance Show t => Show (TypeVar Identity t) 236 | deriving instance Eq t => Eq (TypeVar (STRef s) t) 237 | deriving instance Show t => Show (TypeVar (STRef s) t) 238 | 239 | data TypeABT g v t 240 | = TyVar (TypeVar v t) 241 | | TyAST (TypeAST g t) 242 | deriving (Generic, Functor) 243 | 244 | deriving instance (Eq g, Eq t) => Eq (TypeABT g (STRef s) t) 245 | deriving instance (Show g, Show t) => Show (TypeABT g (STRef s) t) 246 | 247 | instance (HasKind t) => HasKind (TypeABT g v t) where 248 | kind (TyVar tv) = kind tv 249 | kind (TyAST ast) = kind ast 250 | 251 | instance (Ord g, HasGen m t g, HasGen m (TypeVar v t) g) => HasGen m (TypeABT g v t) g where 252 | freeGenVars (TyVar tv) = freeGenVars tv 253 | freeGenVars (TyAST ast) = freeGenVars ast 254 | 255 | instance (Ord g, HasVars m t, HasVars m (TypeVar v t)) => HasVars m (TypeABT g v t) where 256 | freeVars (TyVar tv) = freeVars tv 257 | freeVars (TyAST ast) = freeVars ast 258 | 259 | newtype Fix f = Fix { unFix :: f (Fix f) } 260 | 261 | deriving instance Show (f (Fix f)) => Show (Fix f) 262 | 263 | instance HasKind (f (Fix f)) => HasKind (Fix f) where 264 | kind (Fix t) = kind t 265 | 266 | instance HasGen m (f (Fix f)) g => HasGen m (Fix f) g where 267 | freeGenVars (Fix t) = freeGenVars t 268 | 269 | data SType s = SType (TypeABT Level (STRef s) (SType s)) 270 | 271 | deriving instance Show (TypeABT Level (STRef s) (SType s)) => Show (SType s) 272 | 273 | instance HasKind (SType s) where 274 | kind (SType t) = kind t 275 | 276 | instance HasGen (ST s) (SType s) Level where 277 | freeGenVars (SType t) = freeGenVars t 278 | 279 | instance HasVars (ST s) (SType s) where 280 | freeVars (SType t) = freeVars t 281 | 282 | -- Pure cells 283 | data PCell a = PCell a 284 | deriving (Generic, Show) 285 | 286 | instance HasGen m t g => HasGen m (TypeVar PCell t) g where 287 | freeGenVars (TypeVar (PCell t) _) = freeGenVars t 288 | 289 | deriving instance (Show t) => Show (TypeVar PCell t) 290 | deriving instance (Show g, Show t) => Show (TypeABT g PCell t) 291 | 292 | data PType = PType (TypeABT Level PCell PType) 293 | 294 | deriving instance Show (TypeABT Level PCell PType) => Show PType 295 | 296 | instance HasKind PType where 297 | kind (PType t) = kind t 298 | 299 | instance (Monad m) => HasGen m PType Level where 300 | freeGenVars (PType t) = freeGenVars t 301 | 302 | ---------------------------------------------------------------------- 303 | 304 | type QType s = QualType (SType s) 305 | 306 | type Type = Fix (TypeAST ()) 307 | 308 | normalize :: Type -> Type 309 | normalize (Fix (TyAp t1@(Fix (TyAp f arg)) (Fix (TyGen gvs q)))) 310 | | (f == Fix tyFunc) && OrderedSet.null (runIdentity (freeGenVars arg) `OrderedSet.intersection` OrderedSet.fromList gvs) 311 | = normalize $ Fix $ TyGen gvs (fmap (Fix . TyAp t1) q) 312 | normalize (Fix (TyGen gvs1 (QualType ps1 (Fix (TyGen gvs2 (QualType ps2 t)))))) = normalize $ Fix (TyGen (gvs1++gvs2) $ QualType (ps1++ps2) t) 313 | normalize t = t 314 | 315 | normalizeQual :: QualType Type -> QualType Type 316 | normalizeQual = fmap normalize 317 | deriving instance Generic (f (Fix f)) => Generic (Fix f) 318 | 319 | instance Eq g => Eq (Fix (TypeAST g)) where 320 | (Fix x) == (Fix y) = x == y 321 | 322 | instance Ord g => Ord (Fix (TypeAST g)) where 323 | (Fix x) `compare` (Fix y) = x `compare` y 324 | 325 | 326 | unresolveGV :: GenVar () -> GenVar Level 327 | unresolveGV = fmap (const LevelAny) 328 | 329 | unresolve :: Type -> SType s 330 | unresolve (Fix t) = SType . TyAST $ bimapTypeAST (const LevelAny) unresolve t 331 | 332 | unresolvePred :: Pred Type -> Pred (SType s) 333 | unresolvePred = fmap unresolve 334 | 335 | unresolveQual :: QualType Type -> QType s 336 | unresolveQual (QualType ps t) = QualType (map unresolvePred ps) (unresolve t) 337 | 338 | ---------------------------------------------------------------------- 339 | 340 | data TypeError 341 | = WrappedError TypeError TypeError 342 | | ResolveError String 343 | | UnificationError String String 344 | | RowEndError String 345 | | InferenceError String 346 | | EscapedSkolemError String 347 | | InvalidKind 348 | | KindMismatchError Kind Kind 349 | | InvalidVarError String 350 | | ExpectedFunction String 351 | | SubsumeError String String 352 | | OccursError String String 353 | | AssertionError String 354 | | MultipleErrors [TypeError] 355 | | InstanceMethodMissing String 356 | | InstanceMemberWrongType String 357 | | CallFrame String 358 | deriving (Generic, Eq, Show) 359 | 360 | concatErrors :: TypeError -> TypeError -> TypeError 361 | concatErrors (MultipleErrors e1s) (MultipleErrors e2s) = MultipleErrors (e1s ++ e2s) 362 | concatErrors (MultipleErrors e1s) e = MultipleErrors (e1s ++ [e]) 363 | concatErrors e (MultipleErrors e2s) = MultipleErrors (e:e2s) 364 | concatErrors e1 e2 = MultipleErrors [e1,e2] 365 | 366 | 367 | ---------------------------------------------------------------------- 368 | 369 | newtype MemberName = MemberName String 370 | deriving (Generic, Eq, Ord, Show) 371 | 372 | data Instance t expr = Instance { instCls :: ClassId, instType :: QualType t, instMembers :: Map MemberName expr } 373 | deriving (Generic, Eq, Ord, Show) 374 | 375 | data Class t expr = Class { clsId :: ClassId 376 | , clsSupers :: [ClassId] 377 | , clsParam :: GenVar () -- is used in member types 378 | , clsMembers :: Map MemberName (QualType t) 379 | , clsInstances :: [Instance t expr] 380 | } 381 | deriving (Generic, Eq, Ord, Show) 382 | 383 | data ClassEnv t expr = ClassEnv { cenvClasses :: Map ClassId (Class t expr) } 384 | deriving (Generic, Eq, Ord, Show) 385 | 386 | getMemberType :: Class t expr -> MemberName -> Maybe (TypeAST () t) 387 | getMemberType cls name = TyGen [clsParam cls] <$> Map.lookup name (clsMembers cls) 388 | 389 | -------------------------------------------------------------------------------- 390 | -------------------------------------------------------------------------------- /src/Fresh/Infer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | -- | 5 | 6 | module Fresh.Infer where 7 | 8 | import Data.Functor.Identity 9 | import Fresh.OrderedSet (OrderedSet) 10 | import qualified Fresh.OrderedSet as OrderedSet 11 | 12 | import Control.Monad (when, forM_, unless) 13 | import Control.Monad.Trans.Class (lift) 14 | import Control.Monad.Trans.State (StateT(..), runStateT, evalStateT) 15 | import Control.Monad.State.Class (MonadState(..), modify) 16 | import Control.Monad.Trans.Either (EitherT(..), runEitherT) 17 | import Control.Monad.Error.Class (MonadError(..)) 18 | 19 | import qualified Data.Map as Map 20 | import Control.Monad.ST (runST) 21 | import Data.STRef 22 | 23 | import Fresh.Pretty (Pretty(..)) 24 | import Fresh.Kind (Kind(..)) 25 | import Fresh.Types 26 | import Fresh.Expr 27 | import Fresh.InferMonad 28 | import Fresh.Unify (unify, varBind) 29 | 30 | funT :: SType s -> SType s -> SType s 31 | funT targ tres = 32 | SType . TyAST 33 | $ TyAp (SType . TyAST . TyAp (SType $ TyAST tyFunc) $ targ) tres 34 | 35 | recT :: [(CompositeLabelName, SType s)] -> Maybe (SType s) -> SType s 36 | recT fs rest = 37 | SType . TyAST 38 | $ TyAp (SType $ TyAST tyRec) (SType . TyAST $ TyComp tcomp) 39 | where 40 | tcomp = unflattenComposite (FlatComposite (Map.fromList fs) rest) 41 | 42 | 43 | tcon :: String -> Kind -> SType s 44 | tcon name k = SType (TyAST (TyCon (TCon (Id name) k))) 45 | 46 | inferLit :: (Expr a -> Infer s (InferResult s a)) -> a -> Lit a -> Infer s (InferResult s a) 47 | inferLit r a LitNum{} = return (ELit (a, t) LitNum{}, t) 48 | where t = emptyQual $ tcon "Number" Star 49 | inferLit r a LitString{} = return (ELit (a, t) LitString{}, t) 50 | where t = emptyQual $ tcon "String" Star 51 | inferLit r a LitBool{} = return (ELit (a, t) LitBool{}, t) 52 | where t = emptyQual $ tcon "Bool" Star 53 | inferLit r a (LitStruct []) = return (ELit (a, t) (LitStruct []), t) 54 | where t = emptyQual $ recT [] Nothing 55 | inferLit r a (LitStruct rs) = do 56 | (preds, rts) <- go rs 57 | let rs' = zip (map fst rs) (map fst rts) 58 | ts' = zip (map fst rs) (map snd rts) 59 | t = QualType preds $ (recT ts' Nothing) 60 | return (ELit (a, t) (LitStruct rs'), t) 61 | where 62 | go [] = return ([], []) 63 | go ((fname, fexpr):rs) = do 64 | (fexpr', QualType ps texpr) <- r fexpr 65 | QualType ps2 texpr' <- instantiate texpr 66 | (pss, trs) <- go rs 67 | return (ps++ps2++pss, (fexpr', texpr'):trs) 68 | 69 | runInferError :: InferState s -> Infer s a -> Infer s (Either TypeError (a, InferState s)) 70 | runInferError s act = lift . lift $ runEitherT $ runStateT act s 71 | 72 | subInfer :: InferState s -> Infer s a -> Infer s a 73 | subInfer state' act = do 74 | res <- runInferError state' act 75 | case res of 76 | Left err -> throwError err 77 | Right (x, is') -> do 78 | modify $ \is -> is { isGenFresh = isGenFresh is' } 79 | return x 80 | 81 | withVar :: EVarName -> TypeVar (STRef s) (SType s) -> Infer s a -> Infer s a 82 | withVar v t act = do 83 | is <- get 84 | subInfer (is { isContext = Map.insert v t (isContext is) }) act 85 | 86 | type InferResult s a = (Expr (a, QType s), QType s) 87 | 88 | infer :: Show a => (Expr a -> Infer s (InferResult s a)) -> Expr a -> Infer s (InferResult s a) 89 | 90 | infer r (ELit a lit) = inferLit r a lit 91 | 92 | infer r (EVar a var) = do 93 | is <- get 94 | case Map.lookup var (isContext is) of 95 | Nothing -> throwError $ InvalidVarError (show var) 96 | Just ref -> return (EVar (a, t) var, t) 97 | where t = emptyQual $ SType $ TyVar ref 98 | 99 | infer r (ELam a var expr) = do 100 | (tvar, ps, expr', exprT') <- inLevel $ do 101 | tvar <- freshTVar 102 | (expr', QualType ps exprT) <- withVar var tvar $ r expr 103 | QualType instPs exprT' <- instantiate exprT 104 | return (tvar, ps ++ instPs, expr', exprT') 105 | resT <- generalize ps (funT (SType $ TyVar tvar) exprT') 106 | -- TODO check that tvar is not polymorphic (forall'd) 107 | return (ELam (a, resT) var expr', resT) 108 | 109 | infer r (EALam a var varQ expr) = do 110 | QualType varPs varAT <- instantiateAnnot varQ 111 | (ps, varAT', expr', exprT) <- inLevel $ do 112 | --varAT' <- instantiate varAT 113 | let varAT' = varAT -- TODO instantiate 'some' quantifiers (when we have them) 114 | tvar <- freshTVar 115 | varBind tvar varAT' 116 | (expr', QualType ps exprT) <- withVar var tvar $ r expr 117 | return (ps, varAT', expr', exprT) 118 | QualType instPs exprT' <- instantiate exprT 119 | resT <- generalize (varPs++instPs) $ funT varAT' exprT' 120 | return (EALam (a, resT) var varQ expr', resT) 121 | 122 | infer r (ELet a var edef expr) = do 123 | tvar <- freshTVar 124 | (edef', QualType edefP edefT) <- withVar var tvar $ r edef 125 | unify (SType $ TyVar tvar) edefT 126 | (expr', QualType exprP exprT) <- withVar var tvar $ r expr 127 | let resT = QualType (exprP ++ edefP) exprT 128 | return (ELet (a, resT) var edef' expr', resT) 129 | 130 | infer r (EApp a efun earg) = do 131 | (efun', QualType efunP efunT) <- r efun 132 | (efunArg, efunRes) <- matchFun efunT 133 | (earg', QualType eargP eargT) <- r earg 134 | subsume efunArg eargT 135 | resQ <- generalize (efunP ++ eargP) efunRes 136 | return (EApp (a, resQ) efun' earg', resQ) 137 | 138 | -- Propagate annotations into Let 'manually': 139 | infer r (EAsc a asc (ELet a' var edef expr)) = do 140 | -- TODO handle 'some' quanitifier in annotation 141 | (expr', QualType exprP exprT) <- r (ELet a' var edef (EAsc a asc expr)) 142 | ascQ@(QualType ascP ascT) <- instantiateAnnot asc 143 | -- resQ = QualType (ascP ++ exprP) 144 | subsume ascT exprT 145 | return (EAsc (a, ascQ) asc expr', ascQ) 146 | 147 | -- TODO: Propagate into EApp 148 | infer r (EAsc a asc expr) = do 149 | ascQ <- instantiateAnnot asc 150 | (expr', exprQ) <- r (EApp a (EALam a dummy asc (EVar a dummy)) expr) 151 | return (EAsc (a, ascQ) asc expr', ascQ) 152 | where 153 | dummy = EVarName "_dummy_x_" 154 | 155 | infer r (EGetField a expr name) = do 156 | (expr', QualType exprP exprT) <- r expr 157 | tvar <- SType . TyVar <$> freshTVar 158 | rvar <- SType . TyVar <$> freshRVar 159 | unify exprT (recT [(name, tvar)] $ Just rvar) 160 | let resT = QualType exprP tvar 161 | return (EGetField (a, resT) expr' name, resT) 162 | 163 | infer _r (EBuiltIn a s asc) = do 164 | ascQ <- instantiateAnnot asc 165 | return (EBuiltIn (a, ascQ) s asc, ascQ) 166 | 167 | instantiateAnnot :: ETypeAsc -> Infer s (QualType (SType s)) 168 | instantiateAnnot (ETypeAsc q) = callFrame "instantiateAnnot" $ do 169 | -- TODO: Check the predicates ps to see if they contain escaped genvars from t 170 | gvs <- freeGenVars q :: Infer s (OrderedSet (GenVar ())) 171 | let gvs' = map (fmap $ const LevelAny) $ OrderedSet.toList gvs 172 | QualType ps' t' = unresolveQual q 173 | res <- mkGenQ gvs' ps' t' 174 | resFreeGVs :: (OrderedSet (GenVar Level)) <- liftST $ freeGenVars res 175 | unless (OrderedSet.null resFreeGVs) 176 | $ throwError $ AssertionError ("Genvars escaped from forall'ed annotated type?! " ++ show res) 177 | return res 178 | 179 | -- instantiateAnnot' :: Type -> Infer s (SType s) 180 | -- instantiateAnnot' (Fix ascType) = do 181 | -- case ascType of 182 | -- TyGen gvs tscheme -> do 183 | -- tscheme' <- instantiateAnnot' tscheme 184 | -- tscheme'' <- substGens gvs' (map (SType . TyAST . TyGenVar) freshGVs) tscheme' 185 | -- return . SType . TyAST $ TyGen freshGVs tscheme'' 186 | -- _ -> fmap (SType . TyAST) . sequenceA . bimapTypeAST (const LevelAny) id $ fmap instantiateAnnot' ascType 187 | 188 | data FlatTy t 189 | = FlatTyAp (FlatTy t) (FlatTy t) 190 | | FlatTyLeaf t 191 | 192 | flattenTyAp :: SType s -> FlatTy (SType s) 193 | flattenTyAp (SType (TyAST (TyAp ap res))) = FlatTyAp (flattenTyAp ap) (flattenTyAp res) 194 | flattenTyAp t = FlatTyLeaf t 195 | 196 | unFlattenTy :: FlatTy (SType s) -> SType s 197 | unFlattenTy (FlatTyLeaf t) = t 198 | unFlattenTy (FlatTyAp f1 f2) = SType (TyAST (TyAp (unFlattenTy f1) (unFlattenTy f2))) 199 | 200 | matchFun :: SType s -> Infer s (SType s, SType s) 201 | matchFun t = do 202 | QualType ps t' <- instantiate t 203 | -- TODO unused ps 204 | matchFun' t' 205 | 206 | matchFun' :: SType s -> Infer s (SType s, SType s) 207 | matchFun' t@(SType TyAST{}) 208 | | (FlatTyAp (FlatTyAp cf fArg) fRes) <- flattenTyAp t 209 | , SType (TyAST (TyCon c)) <- unFlattenTy cf 210 | , c == conFunc 211 | = return (unFlattenTy fArg, unFlattenTy fRes) 212 | | otherwise = do 213 | pt <- purify t 214 | throwError $ ExpectedFunction (show $ pretty pt) 215 | 216 | matchFun' (SType (TyVar tvar@(TypeVar _ k))) = callFrame "matchFun' (TypVar)" $ do 217 | t <- readVar tvar 218 | case t of 219 | Link t' -> matchFun t' 220 | Unbound _n l -> do 221 | arg <- SType . TyVar <$> freshTVarK k 222 | res <- SType . TyVar <$> freshTVarK k 223 | writeVar tvar (Link $ funT arg res) 224 | return (arg, res) 225 | 226 | skolemize :: SType s -> Infer s ([GenVar Level], QualType (SType s)) 227 | skolemize (SType (TyAST (TyGen vs (QualType ps t)))) = do 228 | ks <- mapM getKind vs 229 | curLevel <- getCurrentLevel 230 | skolems <- mapM (\k -> GenVar <$> freshName <*> pure k <*> pure curLevel) ks 231 | let skolemTs = map (SType . TyAST . TyGenVar) skolems 232 | t' <- substGens vs skolemTs t 233 | ps' <- mapM (traverse (substGens vs skolemTs)) ps 234 | return (skolems, QualType ps' t') 235 | skolemize t = return ([], QualType [] t) 236 | 237 | subsume :: SType s -> SType s -> Infer s () 238 | subsume t1 t2 = withWrap $ do 239 | (sks, QualType ps1' t1') <- skolemize t1 240 | QualType ps2' t2' <- instantiate t2 241 | unify t1' t2' 242 | gvs1 <- liftST $ freeGenVars t1 243 | gvs2 <- liftST $ freeGenVars t2 244 | let escapingSkolems = OrderedSet.fromList sks `OrderedSet.intersection` (gvs1 `OrderedSet.concatUnion` gvs2) 245 | unless (OrderedSet.null escapingSkolems) 246 | $ throwError 247 | $ EscapedSkolemError 248 | $ concat -- TODO pretty 249 | [ "Type not polymorphic enough to unify" 250 | , "\n\t", "Type 1: ", show $ pretty t1 251 | , "\n\t", "Type 2: ", show $ pretty t2 252 | , "\n", "Skolems would escape: ", show $ pretty $ OrderedSet.toList escapingSkolems 253 | ] 254 | where 255 | withWrap act = act `catchError` wrapError 256 | wrapError = throwError . WrappedError (SubsumeError (show $ pretty t1)(show $ pretty t2)) 257 | 258 | runInfer :: (forall s. Infer s a) -> Either TypeError a 259 | runInfer act = 260 | runST $ runEitherT $ evalStateT act InferState { isContext = Map.empty 261 | , isGenFresh = 0 262 | , isLevel = Level 0 } 263 | 264 | qresolve :: QType s -> Infer s (QualType Type) 265 | qresolve (QualType ps ti) = callFrame "qresolve" $ do 266 | t <- generalize ps ti 267 | let wrapError e = do 268 | pt <- traverse purify t 269 | throwError $ WrappedError (ResolveError (show (pretty pt))) e 270 | mt' <- sequenceA <$> traverse resolve t `catchError` wrapError 271 | case mt' of 272 | (Just t') -> return t' 273 | _ -> throwError $ EscapedSkolemError $ "qresolve:" ++ show mt' 274 | 275 | wrapInfer :: Show a => Expr a -> Infer s (InferResult s a) 276 | wrapInfer expr = do 277 | let wrapError :: TypeError -> Infer s (InferResult s a) 278 | wrapError e = throwError $ WrappedError (InferenceError (show $ pretty expr)) e 279 | infer wrapInfer expr `catchError` wrapError 280 | 281 | inferExprAct :: Show a => Expr a -> Infer s (Expr (a, QualType (SType s))) 282 | inferExprAct expr = callFrame "inferExprAct" $ do 283 | res@(expr', (QualType p t)) <- inLevel $ wrapInfer expr 284 | k <- getKind t 285 | when (k /= Star) $ throwError $ KindMismatchError k Star 286 | return expr' 287 | 288 | inferExpr :: Show a => Expr a -> Either TypeError (Expr (QualType Type)) 289 | inferExpr expr = runInfer $ callFrame "inferExpr" $ do 290 | exprG <- inferExprAct expr 291 | traverse (qresolve . snd) exprG 292 | 293 | isRight :: Either a b -> Bool 294 | isRight Right{} = True 295 | isRight Left{} = False 296 | 297 | trySubsume :: Type -> Type -> Either TypeError () 298 | trySubsume t1 t2 = runInfer $ do 299 | let t1' = unresolve t1 300 | t2' = unresolve t2 301 | subsume t1' t2' 302 | 303 | canSubsume :: Type -> Type -> Either TypeError () 304 | canSubsume = trySubsume 305 | 306 | equivalent :: Type -> Type -> Either TypeError () 307 | equivalent t1 t2 = case (canSubsume t1 t2, canSubsume t2 t1) of 308 | (Left e1, Left e2) -> Left (concatErrors e1 e2) 309 | (Left e, _ ) -> Left e 310 | (_ , Left e ) -> Left e 311 | _ -> Right () 312 | 313 | equivalentPred :: Pred Type -> Pred Type -> Either TypeError () 314 | equivalentPred p1 p2 = fromPred p1 `equivalent` fromPred p2 315 | 316 | equivalentQual' :: QualType Type -> QualType Type -> Either TypeError () 317 | equivalentQual' (QualType p1 t1) (QualType p2 t2) 318 | | length p1 /= length p2 = Left $ AssertionError "Predicates not the same length" 319 | | all (isRight . uncurry equivalentPred) (zip p1 p2) = equivalent t1 t2 320 | | otherwise = Left $ AssertionError "Not equivalent predicates" 321 | 322 | equivalentQual :: QualType Type -> QualType Type -> Either TypeError () 323 | equivalentQual q1 q2 = equivalentQual' (normalizeQual q1) (normalizeQual q2) 324 | 325 | checkClassInstance :: Show a => Class Type expr -> Instance t (Expr a) -> Either TypeError () 326 | checkClassInstance cls inst = runInfer $ do 327 | forM_ (Map.toList $ instMembers inst) $ \(name, expr) -> do 328 | case Map.lookup name (clsMembers cls) of 329 | Nothing -> throwError $ InstanceMethodMissing (show $ pretty name) 330 | Just q -> do 331 | qt <- mkGen [const LevelAny <$> clsParam cls] [] (qualType $ unresolveQual q) 332 | expr' <- inferExprAct expr 333 | subsume (qualType $ snd $ getAnnotation expr') qt 334 | 335 | checkClass :: (Show a) => Class Type (Expr a) -> Either TypeError () 336 | checkClass cls = 337 | runIdentity 338 | $ runEitherT 339 | $ foldr (>>) (return ()) 340 | $ map (EitherT . return . checkClassInstance cls) (clsInstances cls) 341 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | 10 | --module Spec where 11 | 12 | import Test.QuickCheck 13 | 14 | import Data.DeriveTH 15 | import qualified Data.Foldable as Foldable 16 | import Data.Functor.Identity (runIdentity, Identity(..)) 17 | import Control.Monad (void, forM, forM_, when, unless) 18 | import Data.String (IsString(..)) 19 | import Data.Maybe (catMaybes, isJust) 20 | import qualified Data.Map as Map 21 | import qualified Data.Set as Set 22 | import Fresh.Pretty () 23 | import Fresh.Kind (Kind(..)) 24 | import Fresh.Types 25 | import Fresh.Expr (ETypeAsc(..), EVarName(..), Lit(..), Expr(..), getAnnotation) 26 | import Fresh.Infer (inferExpr, runInfer, instantiateAnnot, qresolve, equivalent, equivalentQual, equivalentPred, subsume, skolemize) 27 | import Fresh.Unify (unify) 28 | import Fresh.BuiltIn 29 | import qualified Fresh.OrderedSet as OrderedSet 30 | import Fresh.OrderedSet (OrderedSet) 31 | import qualified Fresh.Types as Types 32 | import qualified Fresh.InferMonad as InferM 33 | import Data.List (inits) 34 | 35 | import System.Environment (getArgs, getProgName) 36 | import Text.PrettyPrint.ANSI.Leijen (Pretty(..), vsep, indent, (<+>), (<$$>), red) 37 | 38 | instance IsString EVarName where 39 | fromString = EVarName 40 | 41 | instance IsString CompositeLabelName where 42 | fromString = CompositeLabelName 43 | 44 | 45 | eithers :: Eq a => (b -> b -> Bool) -> Either a b -> Either a b -> Bool 46 | eithers f (Right r1) (Right r2) = f r1 r2 47 | eithers _ (Left e1) (Left e2) = e1 == e2 48 | eithers _ _ _ = False 49 | 50 | forgetLeft :: Either l r -> Either () r 51 | forgetLeft (Right x) = Right x 52 | forgetLeft (Left _) = Left () 53 | 54 | fromRight :: Either l r -> r 55 | fromRight (Right x) = x 56 | fromRight (Left _) = error "fromRight!" 57 | 58 | constWrap :: Expr () -> Expr () 59 | constWrap = let_ dummy (num 0) 60 | where dummy = "a very long name that won't be generated by arbitrary" 61 | 62 | letWrap :: Expr () -> Expr () 63 | letWrap expr = ("root" ~> expr) ~$ (num 0) 64 | 65 | isRight :: Either a b -> Bool 66 | isRight Right{} = True 67 | isRight Left{} = False 68 | 69 | testEquivTypes :: Either l (QualType Type) -> Either l' (QualType Type) -> Bool 70 | testEquivTypes inferred expected = 71 | eithers (\a b -> isRight $ equivalentQual a b) (forgetLeft inferred) (forgetLeft expected) 72 | 73 | 74 | let_ :: EVarName -> Expr () -> Expr () -> Expr () 75 | let_ = ELet () 76 | 77 | var :: EVarName -> Expr () 78 | var = EVar () 79 | 80 | num :: Double -> Expr () 81 | num = ELit () . LitNum 82 | 83 | str_ :: String -> Expr () 84 | str_ = ELit () . LitString 85 | 86 | infixr 5 ~$ 87 | (~$) :: Expr () -> Expr () -> Expr () 88 | (~$) = EApp () 89 | 90 | infixr 2 ~:: 91 | (~::) :: Expr () -> QualType Type -> Expr () 92 | expr ~:: qual = EAsc () (ETypeAsc qual) expr 93 | 94 | infixr 4 ~> 95 | (~>) :: EVarName -> Expr () -> Expr () 96 | (~>) = ELam () 97 | 98 | infixr 5 ## 99 | (##) :: Expr () -> CompositeLabelName -> Expr () 100 | (##) = EGetField () 101 | 102 | 103 | lama :: EVarName -> QualType Type -> Expr () -> Expr () 104 | lama v t = EALam () v (ETypeAsc t) 105 | 106 | -- Types 107 | 108 | forall :: GenVar () -> Type -> Type 109 | forall gv = foralls [gv] 110 | 111 | forallsQ :: [Pred Type] -> [GenVar ()] -> Type -> Type 112 | forallsQ ps gvs t = Fix $ TyGen gvs (QualType ps t) 113 | 114 | foralls :: [GenVar ()] -> Type -> Type 115 | foralls = forallsQ [] 116 | 117 | gv :: Int -> GenVar () 118 | gv x = GenVar x Star () 119 | 120 | tv :: Int -> Type 121 | tv x = Fix $ TyGenVar $ gv x 122 | 123 | a, b, c, d, e, f, g :: Type 124 | [a, b, c, d, e, f, g] = map tv [0,1,2,3,4,5,6] 125 | a',b',c',d',e',f',g' :: GenVar () 126 | [a',b',c',d',e',f',g'] = map gv [0,1,2,3,4,5,6] 127 | 128 | rv :: Int -> GenVar () 129 | rv x = GenVar x Composite () 130 | rtv :: Int -> Type 131 | rtv x = Fix $ TyGenVar $ rv x 132 | 133 | ra, rb, rc, rd, re, rf, rg :: Type 134 | [ra, rb, rc, rd, re, rf, rg] = map rtv [0,1,2,3,4,5,6] 135 | ra',rb',rc',rd',re',rf',rg' :: GenVar () 136 | [ra',rb',rc',rd',re',rf',rg'] = map rv [0,1,2,3,4,5,6] 137 | 138 | 139 | record :: [(CompositeLabelName, Type)] -> Maybe Type -> Type 140 | record fs rest = Fix tyRec ^$ (Fix $ TyComp c) 141 | where 142 | c = Types.unflattenComposite (FlatComposite (Map.fromList fs) rest) 143 | 144 | -- Tests 145 | 146 | wrapFooLet :: Expr () -> Expr () 147 | wrapFooLet x = let_ "foo" x $ var "foo" 148 | 149 | exampleApIdNum :: Expr () 150 | exampleApIdNum = ("x" ~> var "x") ~$ num 2 151 | 152 | --testClass :: Class 153 | testClass = 154 | Class 155 | { clsId = ClassId "TestClass" 156 | , clsSupers = [] 157 | , clsParam = a' 158 | , clsMembers = Map.empty 159 | , clsInstances = [] 160 | } 161 | 162 | idFunction :: Expr () 163 | idFunction = let_ "id" ("x" ~> var "x") $ var "id" 164 | 165 | idBool :: Expr () 166 | idBool = lama "x" ([] ~=> _Bool) (var "x") 167 | 168 | polyId :: Expr () 169 | polyId = lama "x" ([] ~=> forall a' (a ^-> a)) (var "x") 170 | 171 | examples :: [(Expr (), Either () (QualType Type))] 172 | examples = [ ( ELit () (LitBool False) , Right $ [] ~=> _Bool) 173 | , ( var "x", Left () ) 174 | , ( ("x" ~> var "x") ~:: ([] ~=> (forall a' (a ^-> a) ^-> forall a' (a ^-> a))) 175 | , Right $ [] ~=> forall b' (forall a' (a ^-> a) ^-> (b ^-> b))) 176 | 177 | , ( idFunction , Right $ [] ~=> forall c' (c ^-> c)) 178 | , ( idBool , Right $ [] ~=> (_Bool ^-> _Bool)) 179 | , ( exampleApIdNum , Right $ [] ~=> _Number) 180 | , ( exampleApIdNum ~:: ([] ~=> _Bool), Left ()) 181 | , ( exampleApIdNum ~:: ([] ~=> _Number), Right $ [] ~=> _Number) 182 | -- TODO deal with alpha equivalence, preferrably by 183 | -- making generalization produce ids like GHC 184 | 185 | , ( let_ "id" ("x" ~> (var "x" ~:: ([] ~=> _Number))) $ var "id", 186 | Right $ [] ~=> (_Number ^-> _Number)) 187 | 188 | , ( let_ "id" (lama "x" ([] ~=> forall a' (a ^-> a)) (var "x")) $ var "id" 189 | , Right $ [] ~=> forall e' (forall b' (b ^-> b) ^-> (e ^-> e))) 190 | 191 | , ( let_ "id" ("x" ~> var "x") (var "id") ~:: ([] ~=> (forall a' (a ^-> a) ^-> forall a' (a ^-> a))) 192 | , Right $ [] ~=> (forall a' (a ^-> a) ^-> forall a' (a ^-> a))) 193 | 194 | , ( let_ "id" ("x" ~> (var "x" ~:: ([] ~=> forall d' (d ^-> d)))) $ var "id", 195 | Left ()) -- impredicative instantiation (eta-expansion of polymorphic arguments doens't work) 196 | 197 | , ( idFunction ~:: ([] ~=> forall b' (b ^-> b)), 198 | Right $ [] ~=> forall b' (b ^-> b)) 199 | 200 | , ( idFunction ~:: ([] ~=> forallsQ [PredIs (clsId testClass) b] [b'] (b ^-> b)), 201 | Right $ [] ~=> forallsQ [PredIs (clsId testClass) b] [b'] (b ^-> b)) 202 | 203 | , ( wrapFooLet ("y" ~> let_ "id" ("x" ~> var "y") (var "id")) 204 | , Right $ [] ~=> forall b' (forall d' (b ^-> d ^-> b))) 205 | 206 | , ( wrapFooLet ("y" ~> let_ "id" ("x" ~> var "y") (var "id")) 207 | , Right $ [] ~=> forall b' (forall d' (d ^-> b ^-> d))) 208 | 209 | , ( wrapFooLet ("y" ~> let_ "id" ("x" ~> var "y") (var "id")) 210 | , Right $ [] ~=> forall b' (forall a' (a ^-> b ^-> a))) 211 | 212 | , ( wrapFooLet ("y" ~> let_ "id" ("x" ~> var "y") (var "id")) 213 | , Right $ [] ~=> forall a' (forall b' (a ^-> b ^-> a))) 214 | 215 | , ( let_ "zero" ("x" ~> var "x" ~$ num 0) (var "zero") 216 | , Right $ [] ~=> forall e' ((_Number ^-> e) ^-> e)) 217 | 218 | , ( wrapFooLet ("x" ~> "y" ~> var "x") 219 | , Right $ [] ~=> foralls [f', g'] (f ^-> g ^-> f)) 220 | 221 | , ( "x" ~> var "x" ## "fieldName" 222 | , Right $ [] ~=> foralls [d', re'] (record [("fieldName", d)] (Just re) ^-> d)) 223 | 224 | , ( let_ "id" 225 | ("x" ~> 226 | ((var "x" ## "fieldName") ~:: [] ~=> _Number)) 227 | $ var "id" 228 | , Right $ [] ~=> foralls [rf'] (record [("fieldName", _Number)] (Just rf) ^-> _Number)) 229 | 230 | , ( let_ "record" 231 | (ELit () $ LitStruct [("fieldName", num 0)]) 232 | $ (var "record") 233 | , Right $ [] ~=> (record [("fieldName", _Number)] Nothing)) 234 | 235 | , ( let_ "record" 236 | (ELit () $ LitStruct [("fieldA", num 0), ("fieldB", str_ "bla")]) 237 | $ (var "record") 238 | , Right $ [] ~=> (record [("fieldA", _Number), ("fieldB", _String)] Nothing)) 239 | 240 | , ( let_ "record" 241 | (ELit () $ LitStruct [("polyField", idFunction ~:: ([] ~=> forall b' (b ^-> b)))]) 242 | $ (var "record") 243 | , Right $ [] ~=> (record [("polyField", forall a' $ a ^-> a)] Nothing)) 244 | 245 | , ( let_ "record" 246 | (ELit () $ LitStruct [("polyField", "x" ~> var "x")]) 247 | $ (var "record") 248 | , Right $ [] ~=> forall a' (record [("polyField", a ^-> a)] Nothing)) 249 | 250 | , ( let_ "record" 251 | (ELit () $ LitStruct [("polyField", "x" ~> var "x"), ("polyField2", "x" ~> var "x")]) 252 | $ (var "record") 253 | , Right $ [] ~=> foralls [a',b'] (record [("polyField", a ^-> a), ("polyField2", b ^-> b)] Nothing)) 254 | 255 | , ( EGetField () (ELet () (EVarName "r") (EApp () (EGetField () (EVar () (EVarName "r")) (CompositeLabelName "pbe")) (ELam () (EVarName "x") (EVar () (EVarName "x")))) (EVar () (EVarName "r"))) (CompositeLabelName "nid") 256 | , Left () ) -- occurs 257 | 258 | , ( lama "a" ([PredIs (clsId testClass) e] ~=> e) ("b" ~> ELit () (LitString "c")) 259 | , Right $ [] ~=> forall d' (forallsQ [PredIs (clsId testClass) e] [e'] e ^-> (d ^-> _String)) ) 260 | 261 | , ( lama "a" ([PredIs (clsId testClass) e] ~=> (forall f' f)) ("b" ~> (ELit () (LitString "c"))) 262 | , Right $ [] ~=> forall d' ((forallsQ [PredIs (clsId testClass) e] [e', f'] f) ^-> (d ^-> _String)) ) 263 | 264 | -- (\o -> let y = (\f -> o 464.5855195404157) in "bla") 265 | , ( "o" ~> (let_ "y" ("f" ~> (var "o" ~$ num 123)) (str_ "bla")) 266 | , Right $ [] ~=> forall a' ((_Number ^-> a) ^-> _String)) 267 | 268 | ] 269 | 270 | -- ---------------------------------------------------------------------- 271 | 272 | -- instance Arbitrary (t (Fix t)) => Arbitrary (Fix t) where 273 | -- arbitrary = Fix <$> arbitrary 274 | 275 | instance Arbitrary g => Arbitrary (GenVar g) where 276 | arbitrary = GenVar <$> (getPositive <$> arbitrary) <*> arbitrary <*> arbitrary 277 | shrink (GenVar i k x) = GenVar <$> shrink i <*> shrink k <*> shrink x 278 | 279 | derive makeArbitrary ''Level 280 | 281 | instance Arbitrary Id where 282 | arbitrary = oneof (map (pure . Id) ["A", "B", "C", "D", "E", "F"]) 283 | 284 | instance Arbitrary ClassId where 285 | arbitrary = oneof (map (pure . ClassId) ["A", "B", "C", "D", "E", "F"]) 286 | 287 | instance Arbitrary Kind where 288 | arbitrary = oneof (map pure 289 | [ Star 290 | , Composite 291 | , KArrow Star Star 292 | , KArrow Composite Star 293 | , KArrow (KArrow Star Star) Star 294 | ]) 295 | shrink (KArrow t1 t2) = [t1, t2] 296 | shrink _ = [] 297 | 298 | derive makeArbitrary ''TCon 299 | 300 | arbIdentifier = take 5 <$> shuffle ['a'..'z'] >>= sublistOf 301 | 302 | instance Arbitrary CompositeLabelName where 303 | arbitrary = CompositeLabelName <$> arbIdentifier 304 | 305 | instance Arbitrary MemberName where 306 | arbitrary = MemberName <$> arbIdentifier 307 | 308 | derive makeArbitrary ''Composite 309 | 310 | genTyAp :: Gen Type 311 | genTyAp = do 312 | tf <- suchThat arbitrary $ 313 | \t -> case kind t of 314 | Just KArrow{} -> True 315 | _ -> False 316 | let (Just (KArrow kx _)) = kind tf 317 | tx <- (Fix . TyCon) <$> (TCon <$> arbitrary <*> pure kx) 318 | let res = Fix $ TyAp tf tx 319 | -- assertion: 320 | unless (isJust $ kind res) $ error $ "Wat: " ++ show res 321 | return res 322 | 323 | genTyCon :: Gen TCon 324 | genTyCon = TCon <$> arbitrary <*> arbitrary 325 | 326 | -- genPred :: GenVar () -> Gen (Pred Type) 327 | -- genPred gv = PredIs <$> arbitrary <*> (pure $ Fix $ TyGenVar gv) 328 | 329 | genTyGen :: Gen Type 330 | genTyGen = do 331 | t <- arbitrary :: Gen Type 332 | gvSet <- Types.freeGenVars t 333 | case OrderedSet.toList gvSet of 334 | [] -> pure t 335 | gvs -> pure $ Fix $ TyGen gvs (QualType [] t) 336 | 337 | instance Arbitrary Type where 338 | arbitrary = oneof $ 339 | [ genTyAp 340 | , Fix . TyCon <$> genTyCon 341 | , Fix . TyGenVar <$> arbitrary 342 | , genTyGen 343 | -- , Fix . TyComp <$> arbitrary 344 | ] 345 | 346 | shrink (Fix (TyAp t1 t2)) = [t1, t2] 347 | shrink (Fix TyCon{}) = [] 348 | shrink (Fix TyGenVar{}) = [] 349 | shrink (Fix (TyGen gvs (QualType ps t))) = t : q' ++ pts 350 | where 351 | pts = concatMap Foldable.toList ps 352 | q' = do 353 | gvs' <- shrink gvs 354 | ps' <- shrink ps 355 | return $ Fix $ TyGen gvs' (QualType ps' t) 356 | shrink (Fix TyComp{}) = [] -- TODO 357 | 358 | arbitraryPred :: (HasKind a, Arbitrary a) => a -> Gen (Pred a) 359 | arbitraryPred t = 360 | oneof $ 361 | [ PredIs <$> arbitrary <*> pure t 362 | , PredNoLabel <$> arbitrary <*> pure t 363 | ] 364 | where Just k = kind t 365 | 366 | instance (Arbitrary t, HasKind t) => Arbitrary (Pred t) where 367 | arbitrary = arbitrary >>= arbitraryPred 368 | shrink (PredIs c t) = PredIs <$> shrink c <*> shrink t 369 | shrink (PredNoLabel l t) = PredNoLabel <$> shrink l <*> shrink t 370 | 371 | slowShrinkList :: Arbitrary t => [t] -> [[t]] 372 | slowShrinkList [] = [] 373 | slowShrinkList (x:xs) = [ xs ] 374 | ++ [ x:xs' | xs' <- shrink xs ] 375 | ++ [ x':xs | x' <- shrink x ] 376 | 377 | instance Arbitrary (QualType Type) where 378 | arbitrary = do 379 | t <- arbitrary :: Gen Type 380 | let gvs = OrderedSet.toList $ ((runIdentity $ Types.freeGenVars t) :: OrderedSet (GenVar ())) 381 | gvts = map (Fix . TyGenVar) gvs 382 | gvts' <- oneof (map pure $ inits gvts) 383 | ps <- mapM arbitraryPred gvts' 384 | return $ QualType ps t 385 | shrink (QualType ps t) = (QualType <$> slowShrinkList ps <*> [t]) ++ (QualType <$> [ps] <*> shrink t) 386 | 387 | instance Arbitrary a => Arbitrary (Instance Type (Expr a)) where 388 | arbitrary = Instance <$> arbitrary <*> arbitrary <*> arbitrary 389 | 390 | instance Arbitrary a => Arbitrary (Class Type (Expr a)) where 391 | arbitrary = do 392 | arbId <- arbitrary 393 | arbSupers <- arbitrary 394 | arbParam <- arbitrary 395 | arbMembers <- arbitrary 396 | --arbInstances <- arbitrary 397 | let arbInstances = [] -- hard to generate instances that type check with member types... 398 | return (Class arbId arbSupers arbParam arbMembers arbInstances) 399 | 400 | derive makeArbitrary ''Lit 401 | 402 | instance Arbitrary EVarName where 403 | arbitrary = EVarName . (:[]) <$> oneof (map return ['a'..'z']) 404 | 405 | instance Arbitrary ETypeAsc where 406 | arbitrary = ETypeAsc <$> arbitrary 407 | shrink (ETypeAsc q) = ETypeAsc <$> shrink q 408 | 409 | instance Arbitrary a => Arbitrary (Expr a) where 410 | arbitrary = oneof 411 | [ ELit <$> arbitrary <*> arbitrary 412 | , EVar <$> arbitrary <*> arbitrary 413 | , ELam <$> arbitrary <*> arbitrary <*> arbitrary 414 | , EALam <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary 415 | , EApp <$> arbitrary <*> arbitrary <*> arbitrary 416 | , ELet <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary 417 | , EAsc <$> arbitrary <*> arbitrary <*> arbitrary 418 | , EGetField <$> arbitrary <*> arbitrary <*> arbitrary 419 | , EBuiltIn <$> arbitrary <*> arbitrary <*> arbitrary 420 | ] 421 | shrink (ELit a l) = ELit <$> [a] <*> shrink l 422 | shrink (EVar a v) = EVar <$> [a] <*> shrink v 423 | shrink (ELam a v e) = e : (ELam <$> [a] <*> [v] <*> shrink e) ++ (ELam <$> [a] <*> shrink v <*> [e]) 424 | shrink (EALam a n t e) = e : (EALam <$> [a] <*> [n] <*> shrink t <*> [e]) ++ (EALam <$> [a] <*> [n] <*> [t] <*> shrink e) 425 | shrink (EApp a e1 e2) = e1 : e2 : (EApp <$> [a] <*> shrink e1 <*> [e2]) ++ (EApp <$> [a] <*> [e1] <*> shrink e2) 426 | shrink (ELet a n e1 e2) = e1 : e2 : (ELet <$> [a] <*> [n] <*> shrink e1 <*> [e2]) ++ (ELet <$> [a] <*> [n] <*> [e1] <*> shrink e2) 427 | shrink (EAsc a t e) = e : (EAsc <$> [a] <*> [t] <*> shrink e) ++ (EAsc <$> [a] <*> shrink t <*> [e]) 428 | shrink (EGetField a e n) = e : (EGetField <$> [a] <*> [e] <*> shrink n) ++ (EGetField <$> [a] <*> shrink e <*> [n]) 429 | shrink (EBuiltIn a n t) = (EBuiltIn <$> [a] <*> [n] <*> shrink t) 430 | 431 | prop_ordLevel :: Level -> Bool 432 | prop_ordLevel l = [l] == Set.toList (Set.singleton l `Set.intersection` Set.singleton l) 433 | 434 | -- This just tests the Arbitrary instance for Type: it should only 435 | -- generate valid types (ones that have a kind) 436 | prop_hasKind :: Type -> Bool 437 | prop_hasKind = isJust . kind 438 | 439 | 440 | prop_resolve :: Type -> Bool 441 | prop_resolve t = 442 | case (runInfer $ InferM.resolve (Types.unresolve t)) of 443 | Right (Just t') -> isRight $ equivalent t t' 444 | _ -> False 445 | 446 | 447 | -- TODO: Wrong 448 | prop_skolemize :: Type -> Bool 449 | prop_skolemize t = 450 | case getSkolemized t of 451 | Right (Just s) -> isRight $ equivalent (wrapGen t) (wrapGen s) 452 | _ -> False 453 | where 454 | getSkolemized x = runInfer $ skolemize (Types.unresolve x) >>= (InferM.resolve . Types.qualType . snd) 455 | wrapGen ty = case OrderedSet.toList $ runIdentity $ Types.freeGenVars ty of 456 | [] -> ty 457 | gvs -> Fix $ TyGen gvs (QualType [] ty) 458 | 459 | -- prop_hasKindStar :: Type -> Bool 460 | -- prop_hasKindStar t = Just Star == kind t 461 | 462 | prop_constExpand :: Expr () -> Bool 463 | prop_constExpand expr = 464 | case (getAnnotation <$> inferExpr (constWrap expr), getAnnotation <$> inferExpr expr) of 465 | (Right cres, Right res) -> isRight $ equivalentQual cres res 466 | -- Left (WrappedError _ (WrappedError _ e)) -> Left e == res 467 | -- _ -> error "Expected success or WrappedError on const-wrapped" 468 | (Left{}, Left{}) -> True 469 | _ -> False 470 | 471 | testSubsume :: Type -> Type -> Either TypeError () 472 | testSubsume t1 t2 = runInfer $ subsume (Types.unresolve t1) (Types.unresolve t2) 473 | 474 | prop_selfSubsume :: Type -> Bool 475 | prop_selfSubsume t = 476 | case kind t of 477 | Just k -> isRight $ testSubsume t t 478 | _ -> error "Arbitrary Type must have kind." 479 | 480 | prop_selfSubsumeNormalized :: Type -> Bool 481 | prop_selfSubsumeNormalized t = 482 | case kind t of 483 | Just k -> isRight $ testSubsume t (Types.normalize t) 484 | _ -> error "Arbitrary Type must have kind." 485 | 486 | prop_selfEquivalence :: Type -> Bool 487 | prop_selfEquivalence t = isRight $ equivalent t t 488 | 489 | prop_selfEquivalenceNormalized :: Type -> Bool 490 | prop_selfEquivalenceNormalized t = isRight $ equivalent t (Types.normalize t) 491 | 492 | prop_selfEquivalencePred :: Pred Type -> Bool 493 | prop_selfEquivalencePred p = isRight $ equivalentPred p p 494 | 495 | prop_selfEquivalenceQual :: QualType Type -> Bool 496 | prop_selfEquivalenceQual q = isRight $ equivalentQual q q 497 | 498 | testUnify :: Type -> Type -> Either TypeError () 499 | testUnify t1 t2 = runInfer $ do 500 | (QualType ps1 ut1) <- InferM.instantiate $ Types.unresolve t1 501 | (QualType ps2 ut2) <- InferM.instantiate $ Types.unresolve t2 502 | unify ut1 ut2 503 | 504 | prop_unifySame :: Type -> Bool 505 | prop_unifySame t = 506 | case kind t of 507 | Just Star -> Right () == testUnify t t 508 | _ -> True -- don't test 509 | 510 | shouldUnify :: Bool -> Type -> Type -> IO () 511 | shouldUnify b t1 t2 = do 512 | putStrLn $ "Unifying: " ++ show (pretty t1) ++ " with " ++ show (pretty t2) ++ " - should succeed: " ++ show b 513 | let res = testUnify t1 t2 514 | when (b == (Right () /= res)) $ error $ show $ red $ "Wrong result: " <+> (pretty res) 515 | 516 | erecord :: [(CompositeLabelName, Type)] -> Type 517 | erecord x = record x Nothing 518 | 519 | rightPad :: a -> Int -> [a] -> [a] 520 | rightPad ch n [] 521 | | n > 0 = replicate n ch 522 | | otherwise = [] 523 | rightPad ch n (x:xs) 524 | | n > 0 = x : rightPad ch (n-1) xs 525 | | otherwise = (x:xs) 526 | 527 | return [] 528 | 529 | runTests :: Int -> IO Bool 530 | runTests testCount = $forAllProperties (quickCheckWithResult stdArgs { maxSuccess = testCount }) 531 | 532 | defaultTestCount :: Int 533 | defaultTestCount = 5000 534 | 535 | parseArgs :: IO Int 536 | parseArgs = do 537 | args <- getArgs 538 | case args of 539 | [] -> return defaultTestCount 540 | [x] -> return $ read x 541 | _ -> do 542 | progName <- getProgName 543 | error $ show $ pretty $ "Usage:" <+> pretty progName <+> "[tests count]" 544 | 545 | main :: IO () 546 | main = do 547 | testCount <- parseArgs 548 | putStrLn "Testing..." 549 | shouldUnify True (erecord []) (erecord []) 550 | shouldUnify True (erecord [("x", _Bool)]) (erecord [("x", _Bool)]) 551 | shouldUnify True (erecord [("x", _Bool)]) (forall re' $ record [] $ Just re) 552 | shouldUnify False (erecord [("x", _Bool)]) (erecord [("x", _Number)]) 553 | shouldUnify False (erecord [("x", _Bool)]) (erecord [("y", _Bool)]) 554 | 555 | shouldUnify True (record [("num", _Number)] Nothing) (forall ra' $ record [] (Just ra)) 556 | shouldUnify True (forall ra' $ record [("num", _Number)] (Just ra)) (forall rb' $ record [("bool", _Bool)] (Just rb)) 557 | shouldUnify False (forall ra' $ record [("num", _Number)] (Just ra)) (forall rb' $ record [("num", _Bool)] (Just rb)) 558 | 559 | merrs <- forM examples $ \(x, t) -> do 560 | putStrLn "------------------------------------------------------------" 561 | putStr $ rightPad ' ' 40 $ show $ pretty x 562 | putStr " :: (inferred) " 563 | let x' = letWrap x 564 | inferredType = getAnnotation <$> inferExpr x' 565 | conInferredType = getAnnotation <$> inferExpr (constWrap x') 566 | msgTypes = vsep 567 | [ "Expected:" <$$> (pretty t) -- , " = " , ( t) , "\n" 568 | , "Expected (normalized):" <$$> pretty (Types.normalizeQual <$> t) 569 | , "Inferred:" <$$> (pretty inferredType) -- , " = " , ( inferredType) 570 | , "Inferred (normalized):" <$$> pretty (Types.normalizeQual <$> inferredType) 571 | , "Inferred (raw): " <$$> (pretty $ show inferredType) 572 | , "Constwrap-Inferred:" <$$> pretty conInferredType -- , " = " , (show inferredType) , "\n" 573 | , "Constwrap-Inferred (raw): " <$$> (pretty $ show conInferredType) 574 | ] 575 | errMsgInfer = Just $ pretty $ vsep 576 | [ "TEST FAILED!" 577 | , "Wrong type inferred for:" <+> pretty x 578 | ] <$$> (indent 4 msgTypes) 579 | print . pretty $ inferredType 580 | if (not $ testEquivTypes inferredType conInferredType) 581 | then return $ Just $ pretty $ vsep 582 | [ "TEST FAILED!" 583 | , "Type not equivalent to constwrap of itself:" 584 | , pretty inferredType 585 | , pretty conInferredType 586 | , "When checking inferred types:" 587 | , indent 4 msgTypes 588 | ] 589 | else if ((testEquivTypes inferredType t) && (testEquivTypes conInferredType t)) 590 | then return Nothing 591 | else return errMsgInfer 592 | 593 | let errs = catMaybes merrs 594 | unless (null errs) $ 595 | forM_ errs (print . red) 596 | putStrLn "------------------------------------------------------------" 597 | void $ runTests testCount 598 | 599 | 600 | -- TODO: Check this example, it fails constWrap and also infers a type 601 | -- that shadows some genvar (e) in the ETypeAsc: 602 | -- let t = EALam () (EVarName "a") (ETypeAsc (QualType {qualPred = [PredIs (clsId testClass) (Fix {unFix = TyGenVar {_tyGenVar = GenVar {genVarId = 4, genVarKind = Star, genVarAnnot = ()}}})], 603 | -- qualType = Fix {unFix = TyGenVar {_tyGenVar = GenVar {genVarId = 5, genVarKind = Star, genVarAnnot = ()}}} 604 | -- })) 605 | -- (ELam () (EVarName "b") (ELit () (LitString "c"))) 606 | -- lama "a" ([PredIs (clsId testClass) e'] ~=> ("b" ~> (ELit () (LitString "c")))) 607 | --------------------------------------------------------------------------------