├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── haskell-tc.cabal ├── presentation ├── haskell-suite.png ├── slides.pdf └── slides.tex ├── src └── Language │ └── Haskell │ ├── TypeCheck.hs │ └── TypeCheck │ ├── Debug.hs │ ├── Misc.hs │ ├── Monad.hs │ ├── Pretty.hs │ ├── Proof.hs │ ├── Subsumption.hs │ ├── SyntaxDirected.hs │ ├── Types.hs │ └── Unify.hs ├── stack.yaml └── tests ├── AbsAp1.hs ├── AbsAp1.stdout ├── AbsAp2.hs ├── AbsAp2.stdout ├── AbsAp3.hs ├── AbsAp3.stdout ├── AbsAp4.hs ├── AbsAp4.stdout ├── Append.hs ├── Append.stdout ├── Basic1.hs ├── Basic1.stdout ├── Bug1.hs ├── Bug1.stdout ├── Bug2.hs ├── Bug2.stdout ├── Bug3.hs ├── Bug3.stdout ├── Class1.hs ├── Class1.stdout ├── Class2.hs ├── Class2.stdout ├── Class3.hs ├── Class3.stdout ├── Class4.hs ├── Class4.stdout ├── Class5.hs ├── Class5.stdout ├── Class6.hs ├── Class6.stdout ├── Do1.hs ├── InlinePragma.hs ├── InlinePragma.stdout ├── Map.hs ├── Map.stdout ├── Naming1.hs ├── Naming1.stdout ├── Naming2.hs ├── Naming2.stdout ├── Naming3.hs ├── Naming3.stdout ├── Naming4.hs ├── Naming4.stdout ├── Naming5.hs ├── Pattern1.hs ├── Pattern1.stdout ├── Pattern2.hs ├── Pattern2.stdout ├── Pattern3.hs ├── Pattern3.stdout ├── RankN1.hs ├── Rec1.hs ├── Rec2.hs ├── Rec3.hs ├── Rec4.hs └── runtests.hs /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | 3 | language: generic 4 | 5 | os: 6 | - linux 7 | - osx 8 | 9 | cache: 10 | directories: 11 | - $HOME/.stack 12 | - $HOME/.local/bin 13 | - .stack-work/ 14 | 15 | before_install: 16 | - mkdir -p ~/.local/bin 17 | - export PATH=$HOME/.local/bin:$PATH 18 | - | 19 | if [ `uname` = "Darwin" ] 20 | then 21 | travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 22 | else 23 | travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 24 | fi 25 | - stack install happy alex 26 | 27 | script: 28 | - stack setup 29 | - stack build 30 | - stack test 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 David Himmelstrup 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/haskell-suite/haskell-tc.svg?branch=master)](https://travis-ci.org/haskell-suite/haskell-tc) 2 | 3 | haskell-tc 4 | ========== 5 | 6 | This package contains an implementation of a bidirectional typechecker for Haskell. 7 | 8 | TC Overview 9 | =========== 10 | 11 | I'm no expert on type theory. This is how thing make sense in my head; take it with a grain of salt. 12 | 13 | Basic HM 14 | -------- 15 | 16 | Simple yet powerful type-inference by unification. 17 | 18 | Bidirectional 19 | ------------- 20 | 21 | Extention to HM. Works on higher rank types. Eg: 22 | 23 | fn :: (forall a. [a] -> [a]) -> ([Int],[Char]) 24 | fn g = (g [1,2,3], g ['a','b','c']) 25 | 26 | It's bidirectional because it can either do type-checking (down) or type-inference (up). This means it can verify the correctness of user-written higher ranked types even though it wouldn't be able to infer those types. 27 | 28 | Boxy types 29 | ---------- 30 | Extension to bidirectional TC. Instead of having to distinct modes (up and down), this system can work with partial type signatures, checking what is known and inferring the rest. This granularity is required when using higher ranked types together with polymorphic data types. Eg: 31 | 32 | fn :: Maybe (forall a. [a] -> [a]) -> ([Int],[Char]) 33 | fn Nothing = ([],[]) 34 | fn (Just g) = (g [1,2,3], g ['a','b','c']) 35 | 36 | The same goes for using higher ranked types together with polymorphic functions. In the following example, '$' has a polymorphic type and 'runST' has a rank-2 type. 37 | 38 | fn = runST $ do ... 39 | 40 | This is called impredicativity. Both HM and Bidirectional are predicative. Boxy types are implemented by jhc. 41 | 42 | OutsideIn 43 | --------- 44 | 45 | The latest and greatest. Breaks the pattern of the previous extensions by strictly speaking not being backwards compatible with HM. Used by GHC. 46 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /haskell-tc.cabal: -------------------------------------------------------------------------------- 1 | -- Initial haskell-tc.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: haskell-tc 5 | version: 0.1.0.0 6 | synopsis: Haskell typechecker. 7 | -- description: 8 | license: MIT 9 | license-file: LICENSE 10 | author: David Himmelstrup 11 | maintainer: lemmih@gmail.com 12 | -- copyright: 13 | category: Language 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Language.Haskell.TypeCheck, 20 | Language.Haskell.TypeCheck.Pretty 21 | other-modules: Language.Haskell.TypeCheck.Unify, 22 | Language.Haskell.TypeCheck.Types, 23 | Language.Haskell.TypeCheck.Proof, 24 | Language.Haskell.TypeCheck.SyntaxDirected, 25 | Language.Haskell.TypeCheck.Misc, 26 | Language.Haskell.TypeCheck.Subsumption, 27 | Language.Haskell.TypeCheck.Monad, 28 | Language.Haskell.TypeCheck.Debug 29 | -- other-modules: 30 | other-extensions: GeneralizedNewtypeDeriving 31 | build-depends: base >=4.11 && <5, 32 | haskell-scope >=0.1 && <0.2, 33 | haskell-src-exts >=1.21 && <1.22, 34 | mtl >=2.2 && <2.3, 35 | containers >=0.5 && <0.7, 36 | ansi-wl-pprint >=0.6 && <0.7, 37 | pretty >=1.1 && <1.2 38 | hs-source-dirs: src 39 | default-language: Haskell2010 40 | ghc-options: -W 41 | 42 | test-suite spec 43 | type: exitcode-stdio-1.0 44 | main-is: runtests.hs 45 | hs-source-dirs: tests 46 | build-depends: base >=4.11 && <5, 47 | haskell-scope >=0.1 && <0.2, 48 | haskell-src-exts >=1.21 && <1.22, 49 | mtl >=2.2 && <2.3, 50 | containers >=0.5 && <0.7, 51 | ansi-wl-pprint >=0.6 && <0.7, 52 | pretty >=1.1 && <1.2, 53 | haskell-tc, 54 | directory, filepath, text, bytestring, 55 | tasty, 56 | tasty-golden, 57 | tasty-expected-failure 58 | default-language: Haskell2010 59 | ghc-options: -Wall -Werror 60 | -------------------------------------------------------------------------------- /presentation/haskell-suite.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-suite/haskell-tc/abf5e3cc624e0095cae14c3c1c695b76ea8ffcb9/presentation/haskell-suite.png -------------------------------------------------------------------------------- /presentation/slides.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-suite/haskell-tc/abf5e3cc624e0095cae14c3c1c695b76ea8ffcb9/presentation/slides.pdf -------------------------------------------------------------------------------- /presentation/slides.tex: -------------------------------------------------------------------------------- 1 | \documentclass[pdf]{beamer} 2 | 3 | \usepackage{color} 4 | \usepackage{listings} 5 | 6 | %\mode { \setbeamercovered{transparent} } 7 | \mode{} 8 | 9 | \title{Design of a typechecker} 10 | \author{David Himmelstrup} 11 | \date{May 8th, 2019} 12 | 13 | %\def\beamerorig@set@color{% 14 | % \pdfliteral{\current@color}% 15 | % \aftergroup\reset@color 16 | %} 17 | %\def\beamerorig@reset@color{\pdfliteral{\current@color}} 18 | 19 | \begin{document} 20 | 21 | \begin{frame} 22 | \titlepage 23 | \end{frame} 24 | 25 | \begin{frame}{Haskell Suite} 26 | \begin{center} 27 | \includegraphics[scale=0.5]{haskell-suite.png} 28 | \end{center} 29 | \end{frame} 30 | 31 | \begin{frame} 32 | \begin{itemize} 33 | \item \makebox[4cm]{haskell-src-exts\hfill} :: String $\rightarrow$ AST SrcLoc 34 | \item \makebox[4cm]{haskell-scope\hfill} :: AST SrcLoc $\rightarrow$ AST Origin 35 | \item \makebox[4cm]{haskell-tc\hfill} :: AST Origin $\rightarrow$ ??? 36 | \pause 37 | \item \makebox[4cm]{typing-haskell-in-haskell\hfill} :: AST $\rightarrow$ [TypeSig] 38 | \end{itemize} 39 | \end{frame} 40 | 41 | \begin{frame}{Use-cases} 42 | \begin{itemize} 43 | \item Compilers 44 | \item Documentation systems 45 | \item Type-directed source code suggestions 46 | \item Teaching 47 | \end{itemize} 48 | \end{frame} 49 | 50 | \begin{frame}{GHC} 51 | \begin{itemize} 52 | \item Shuffles code 53 | \item Deletes code 54 | \item Adds new code 55 | \item Names every type variable 'p' 56 | \end{itemize} 57 | \end{frame} 58 | 59 | \begin{frame} 60 | \begin{center} 61 | \texttt{\underline{length} "pie"} 62 | \end{center} 63 | \pause 64 | \mode { \setbeamercovered{transparent} } 65 | \begin{align*} 66 | \forall a. [a] \rightarrow Int & \qquad \longrightarrow & [Char] \rightarrow Int \\ 67 | \pause 68 | & \qquad @Char \\ 69 | \end{align*} 70 | \end{frame} 71 | 72 | \begin{frame} 73 | \begin{center} 74 | \texttt{\underline{f}} 75 | \end{center} 76 | \pause 77 | \mode { \setbeamercovered{transparent} } 78 | \begin{align*} 79 | \forall a. a \rightarrow \forall b. b & \qquad \qquad \qquad \longrightarrow & \forall a b. a \rightarrow b\\ 80 | \pause 81 | & \qquad \Lambda a b. \lambda arg. \texttt{f @a arg @b} \\ 82 | \end{align*} 83 | \end{frame} 84 | 85 | \begin{frame} 86 | \makebox[4cm]{haskell-tc\hfill} :: AST Origin $\rightarrow$ AST Typed 87 | 88 | Type signature for bindings, coercions for each usage site. 89 | \end{frame} 90 | 91 | \begin{frame}{Problems} 92 | \mode { \setbeamercovered{transparent} } 93 | \begin{enumerate} 94 | \item Code shuffle 95 | 96 | \uncover<2->{ 97 | Annotate AST with mutable references. Apply TC algorithm. Freeze AST. 98 | } 99 | \item Naming type variables 100 | 101 | \uncover<3->{ 102 | \begin{itemize} 103 | \item No scoping rules. 104 | \item Preference to user-written types. 105 | \item No shadowing. 106 | \end{itemize} 107 | } 108 | \end{enumerate} 109 | \end{frame} 110 | 111 | \begin{frame}[fragile]{Naming} 112 | \begin{lstlisting}[language=Haskell] 113 | const x _ = x 114 | where 115 | id x = x 116 | \end{lstlisting} 117 | \end{frame} 118 | 119 | \begin{frame}[fragile]{Naming} 120 | \begin{lstlisting}[language=Haskell,mathescape=true] 121 | const :: $\forall a b. a \rightarrow b \rightarrow a$ 122 | const x _ = x 123 | where 124 | id :: $\forall c. c \rightarrow c$ 125 | id x = x 126 | \end{lstlisting} 127 | \end{frame} 128 | 129 | 130 | 131 | 132 | \begin{frame}[fragile]{Naming} 133 | \begin{lstlisting}[language=Haskell,mathescape=true] 134 | outer x = x 135 | where 136 | inner :: a -> a 137 | inner y = const x y 138 | \end{lstlisting} 139 | \end{frame} 140 | 141 | \begin{frame}[fragile]{Naming} 142 | \begin{lstlisting}[language=Haskell,mathescape=true] 143 | outer :: $\forall b. b \rightarrow b$ 144 | outer x = x 145 | where 146 | inner :: $\forall a. a \rightarrow a$ 147 | inner y = const @a @b y x 148 | \end{lstlisting} 149 | \end{frame} 150 | 151 | 152 | 153 | 154 | 155 | \begin{frame}[fragile]{Naming} 156 | \begin{lstlisting}[language=Haskell,mathescape=true] 157 | id1 x = id2 x 158 | id2 x = id1 x 159 | \end{lstlisting} 160 | \end{frame} 161 | 162 | \begin{frame}[fragile]{Naming} 163 | \begin{lstlisting}[language=Haskell,mathescape=true] 164 | id1 :: $\forall a b. a \rightarrow b$ 165 | id1 x = id2 x 166 | id2 :: $\forall a b. a \rightarrow b$ 167 | id2 x = id1 x 168 | \end{lstlisting} 169 | \end{frame} 170 | 171 | \begin{frame} 172 | \Large{haskell-tc} 173 | \begin{itemize} 174 | \item Pure API (with ST under the hood) 175 | \item Annotates, never modifies 176 | \item Human-readable output 177 | \item Aims to support Haskell2010 + RankNTypes 178 | \end{itemize} 179 | \end{frame} 180 | 181 | \end{document} 182 | -------------------------------------------------------------------------------- /src/Language/Haskell/TypeCheck.hs: -------------------------------------------------------------------------------- 1 | module Language.Haskell.TypeCheck 2 | ( module Language.Haskell.TypeCheck.Types 3 | , reifyProof 4 | , TcEnv(..), emptyTcEnv 5 | , typecheck 6 | ) where 7 | 8 | import Language.Haskell.Scope 9 | import Language.Haskell.TypeCheck.Types 10 | import Language.Haskell.TypeCheck.Proof 11 | import Language.Haskell.TypeCheck.Monad 12 | import Language.Haskell.TypeCheck.Misc 13 | import Language.Haskell.TypeCheck.SyntaxDirected 14 | -- import Language.Haskell.TypeCheck.Annotate 15 | 16 | import Language.Haskell.Exts 17 | 18 | import Control.Monad.ST 19 | import Control.Monad.Except 20 | import Control.Monad.State 21 | import qualified Data.Map as Map 22 | 23 | {- 24 | Scan module, collect type signatures 25 | 26 | 27 | -} 28 | 29 | typecheck :: TcEnv -> Module Origin -> Either TIError (Module Typed, TcEnv) 30 | typecheck env ast = runST (evalStateT (runExceptT (unTI f)) st) 31 | where 32 | st = emptyTcState 33 | { tcStateValues = Map.map toTcType (tcEnvValues env) } 34 | f = do 35 | pinned <- pinAST ast 36 | tiModule pinned 37 | typed <- unpinAST pinned 38 | tys <- getZonkedTypes 39 | return (typed, TcEnv tys) 40 | -------------------------------------------------------------------------------- /src/Language/Haskell/TypeCheck/Debug.hs: -------------------------------------------------------------------------------- 1 | module Language.Haskell.TypeCheck.Debug where 2 | 3 | import Language.Haskell.Scope 4 | import Language.Haskell.TypeCheck.Monad 5 | import Language.Haskell.TypeCheck.Types 6 | 7 | import Data.List 8 | import Data.STRef 9 | 10 | type Verbose = Bool 11 | 12 | class DebugShow a where 13 | dshow :: Verbose -> a -> String 14 | 15 | instance DebugShow Entity where 16 | dshow verbose = dshow verbose . entityName 17 | 18 | instance DebugShow QualifiedName where 19 | dshow _ (QualifiedName _ ident) = ident 20 | 21 | instance DebugShow a => DebugShow [a] where 22 | dshow verbose lst = "[" ++ intercalate ", " (map (dshow verbose) lst) ++ "]" 23 | 24 | -- instance DebugShow (TcType s) where 25 | -- dshow verbose ty = show (runresolveMetaVars ty) 26 | 27 | resolveMetaVars :: TcType s -> TI s (TcType s) 28 | resolveMetaVars ty = 29 | case ty of 30 | TcForall tyvars (TcQual predicates tty) -> 31 | TcForall tyvars <$> (TcQual <$> mapM resolvePredicate predicates <*> resolveMetaVars tty) 32 | TcFun a b -> TcFun <$> resolveMetaVars a <*> resolveMetaVars b 33 | TcApp a b -> TcApp <$> resolveMetaVars a <*> resolveMetaVars b 34 | TcRef var -> pure $ TcRef var 35 | TcCon con -> pure $ TcCon con 36 | TcMetaVar (TcMetaRef name meta) -> do 37 | mbTy <- liftST (readSTRef meta) 38 | case mbTy of 39 | Nothing -> pure $ TcMetaVar (TcMetaRef name meta) 40 | Just sub -> resolveMetaVars sub 41 | TcUnboxedTuple tys -> TcUnboxedTuple <$> mapM resolveMetaVars tys 42 | TcTuple tys -> TcTuple <$> mapM resolveMetaVars tys 43 | TcList elt -> TcList <$> resolveMetaVars elt 44 | TcStar -> pure TcStar 45 | 46 | resolvePredicate :: TcPred s -> TI s (TcPred s) 47 | resolvePredicate (TcIsIn className ty) = TcIsIn className <$> resolveMetaVars ty 48 | -------------------------------------------------------------------------------- /src/Language/Haskell/TypeCheck/Misc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ParallelListComp #-} 2 | module Language.Haskell.TypeCheck.Misc where 3 | 4 | import Language.Haskell.Scope 5 | import Language.Haskell.TypeCheck.Monad 6 | -- import qualified Language.Haskell.TypeCheck.Pretty as Doc 7 | import Language.Haskell.TypeCheck.Types 8 | 9 | import Control.Monad.Except 10 | import Control.Monad.State 11 | import Data.Either 12 | import Data.List 13 | import Data.Map (Map) 14 | import qualified Data.Map as Map 15 | import Data.Maybe 16 | import Data.Set (Set) 17 | import qualified Data.Set as Set 18 | import Data.STRef 19 | 20 | -- property: \ty -> getFreeTyVars ty == [] 21 | -- property: \tv -> do (tvs, rho, coercion) <- skolemize ty 22 | -- all (`elem` tvs) <$> getFreeTyVars rho 23 | getFreeTyVars :: [TcType s] -> TI s [TcVar] 24 | getFreeTyVars tys = goMany [] tys [] 25 | where 26 | goMany _bound [] acc = pure acc 27 | goMany bound (x:xs) acc = go bound x acc >>= goMany bound xs 28 | go bound ty acc = 29 | case ty of 30 | TcForall tvs (TcQual _ ty') -> go (tvs ++ bound) ty' acc 31 | TcFun a b -> go bound a =<< go bound b acc 32 | TcApp a b -> go bound a =<< go bound b acc 33 | TcRef v | v `elem` bound -> pure acc 34 | | v `elem` acc -> pure acc 35 | | otherwise -> pure (v:acc) 36 | TcCon{} -> pure acc 37 | TcUnboxedTuple tys -> goMany bound tys acc 38 | TcMetaVar (TcMetaRef _ ref) -> do 39 | mbTy <- liftST $ readSTRef ref 40 | case mbTy of 41 | Just ty' -> go bound ty' acc 42 | Nothing -> pure acc 43 | TcTuple tys -> goMany bound tys acc 44 | TcList elt -> go bound elt acc 45 | TcStar -> pure acc 46 | 47 | getAllTyVars :: [TcType s] -> TI s [TcVar] 48 | getAllTyVars tys = reverse <$> goMany tys [] 49 | where 50 | goMany [] acc = pure acc 51 | goMany (x:xs) acc = go x acc >>= goMany xs 52 | go ty acc = 53 | case ty of 54 | TcForall _tvs (TcQual _ ty') -> go ty' acc 55 | TcFun a b -> go b =<< go a acc 56 | TcApp a b -> go a =<< go b acc 57 | TcRef v | v `elem` acc -> pure acc 58 | | otherwise -> pure (v:acc) 59 | TcCon{} -> pure acc 60 | TcUnboxedTuple tys -> goMany tys acc 61 | TcMetaVar (TcMetaRef _ ref) -> do 62 | mbTy <- liftST $ readSTRef ref 63 | case mbTy of 64 | Just ty' -> go ty' acc 65 | Nothing -> pure acc 66 | TcTuple tys -> goMany tys acc 67 | TcList elt -> go elt acc 68 | TcStar -> pure acc 69 | 70 | predFreeTyVars :: [TcPred s] -> TI s [TcVar] 71 | predFreeTyVars preds = getFreeTyVars [ ty | TcIsIn _class ty <- preds ] 72 | 73 | explicitTcForall :: TcType s -> TI s (TcType s) 74 | explicitTcForall src@(TcForall tvs qual) = do 75 | tvs' <- getFreeTyVars [src] 76 | return $ TcForall (tvs++tvs') qual 77 | explicitTcForall ty = do 78 | tvs <- getFreeTyVars [ty] 79 | return $ TcForall tvs (TcQual [] ty) 80 | 81 | 82 | getEnvTypes :: TI s [Sigma s] 83 | getEnvTypes = do 84 | m <- gets tcStateValues 85 | return (Map.elems m) 86 | 87 | getZonkedTypes :: TI s (Map Entity Type) 88 | getZonkedTypes = do 89 | tys <- Map.assocs <$> gets tcStateValues 90 | Map.fromList <$> forM tys (\(name, ty) -> do 91 | ty' <- zonkType ty 92 | return (name, ty')) 93 | 94 | -- property: \ty -> do (tvs, rho, _) <- skolemize ty 95 | -- (ty', proof) <- instantiate (TcForall tvs (TcQual [] rho)) 96 | -- meta <- getMetaTyVars [ty'] 97 | -- length meta <= length tvs 98 | getMetaTyVars :: [TcType s] -> TI s [TcMetaVar s] 99 | getMetaTyVars tys = goMany tys [] 100 | where 101 | goMany [] acc = pure acc 102 | goMany (x:xs) acc = go x acc >>= goMany xs 103 | go ty acc = 104 | case ty of 105 | TcForall _tvs (TcQual _ ty') -> go ty' acc 106 | TcFun a b -> go a =<< go b acc 107 | TcApp a b -> go a =<< go b acc 108 | TcRef {} -> pure acc 109 | TcCon{} -> pure acc 110 | TcUnboxedTuple tys -> goMany tys acc 111 | TcMetaVar var@(TcMetaRef _ ref) -> do 112 | mbTy <- liftST $ readSTRef ref 113 | case mbTy of 114 | Just ty' -> go ty' acc 115 | Nothing 116 | | var `elem` acc -> pure acc 117 | | otherwise -> pure (var:acc) 118 | TcTuple tys -> goMany tys acc 119 | TcList elt -> go elt acc 120 | TcStar -> pure acc 121 | 122 | getProofMetaTyVars :: TcProof s -> TI s [TcMetaVar s] 123 | getProofMetaTyVars p = 124 | case p of 125 | TcProofAbs _ p' -> getProofMetaTyVars p' 126 | TcProofAp p' ts -> liftM2 (++) (getMetaTyVars ts) (getProofMetaTyVars p') 127 | TcProofLam _ t p' -> liftM2 (++) (getMetaTyVars [t]) (getProofMetaTyVars p') 128 | TcProofSrc t -> getMetaTyVars [t] 129 | TcProofPAp pl pr -> liftM2 (++) (getProofMetaTyVars pl) (getProofMetaTyVars pr) 130 | TcProofVar{} -> pure [] 131 | 132 | getProofTyVars :: TcProof s -> TI s (Set String) 133 | getProofTyVars p = 134 | case p of 135 | TcProofAbs tvs p' -> flip Set.difference (toSet tvs) <$> getProofTyVars p' 136 | TcProofAp p' ts -> liftM2 (Set.union) (fromTy ts) (getProofTyVars p') 137 | TcProofLam _ t p' -> liftM2 (Set.union) (fromTy [t]) (getProofTyVars p') 138 | TcProofSrc t -> fromTy [t] 139 | TcProofPAp pl pr -> liftM2 (Set.union) (getProofTyVars pl) (getProofTyVars pr) 140 | TcProofVar{} -> pure Set.empty 141 | where 142 | toSet tvs = Set.fromList $ 143 | [ name | TcVar name _ <- tvs ] ++ [ name | TcSkolemVar name <- tvs ] 144 | fromTy tys = do 145 | lst <- getFreeTyVars tys 146 | return $ toSet lst 147 | 148 | getProofUniques :: TcProof s -> TI s [Int] 149 | getProofUniques p = 150 | case p of 151 | TcProofAbs _ p' -> getProofUniques p' 152 | TcProofAp p' ts -> liftM2 (++) (fromTy ts) (getProofUniques p') 153 | TcProofLam _ t p' -> liftM2 (++) (fromTy [t]) (getProofUniques p') 154 | TcProofSrc t -> fromTy [t] 155 | TcProofPAp pl pr -> liftM2 (++) (getProofUniques pl) (getProofUniques pr) 156 | TcProofVar{} -> pure [] 157 | where 158 | fromTy tys = do 159 | lst <- getAllTyVars tys 160 | return $ [ u | TcUniqueVar u <- lst ] 161 | 162 | predMetaTyVars :: [TcPred s] -> TI s [TcMetaVar s] 163 | predMetaTyVars preds = getMetaTyVars [ ty | TcIsIn _class ty <- preds ] 164 | 165 | 166 | getFreeMetaVariables :: TI s [TcMetaVar s] 167 | getFreeMetaVariables = getMetaTyVars =<< getEnvTypes 168 | 169 | lowerMetaVars :: TcType s -> TI s (TcType s) 170 | lowerMetaVars = substituteTyVars [] 171 | 172 | lowerPredMetaVars :: TcPred s -> TI s (TcPred s) 173 | lowerPredMetaVars (TcIsIn className ty) = 174 | TcIsIn className <$> substituteTyVars [] ty 175 | 176 | substituteTyVars :: [(TcVar, TcType s)] -> TcType s -> TI s (TcType s) 177 | substituteTyVars vars = go 178 | where 179 | go (TcForall tvs (TcQual preds ty)) = TcForall tvs . TcQual preds <$> go ty 180 | go (TcFun a b) = TcFun <$> go a <*> go b 181 | go (TcApp a b) = TcApp <$> go a <*> go b 182 | go (TcRef var) = 183 | case lookup var vars of 184 | Nothing -> pure $ TcRef var 185 | Just ty -> pure ty 186 | go (TcCon con) = pure $ TcCon con 187 | go (TcMetaVar meta@(TcMetaRef _name var)) = do 188 | mbVal <- liftST $ readSTRef var 189 | case mbVal of 190 | Nothing -> pure $ TcMetaVar meta 191 | Just val -> go val 192 | go (TcUnboxedTuple tys) = TcUnboxedTuple <$> mapM go tys 193 | go (TcTuple tys) = TcTuple <$> mapM go tys 194 | go (TcList ty) = TcList <$> go ty 195 | go TcStar = pure TcStar 196 | 197 | substituteTyVarsPred :: [(TcVar, TcType s)] -> TcPred s -> TI s (TcPred s) 198 | substituteTyVarsPred var (TcIsIn cls ty) = 199 | TcIsIn cls <$> substituteTyVars var ty 200 | 201 | mapTcPredM :: (TcType s -> TI s (TcType s)) -> TcPred s -> TI s (TcPred s) 202 | mapTcPredM fn (TcIsIn className ty) = TcIsIn className <$> fn ty 203 | 204 | substituteMetaVars :: [(TcMetaVar s,TcType s)] -> TcType s -> TI s (TcType s) 205 | substituteMetaVars vars = go 206 | where 207 | go (TcForall tvs (TcQual preds ty)) = TcForall tvs <$> (TcQual preds <$> go ty) 208 | go (TcFun a b) = TcFun <$> go a <*> go b 209 | go (TcApp a b) = TcApp <$> go a <*> go b 210 | go (TcRef var) = pure $ TcRef var 211 | go (TcCon con) = pure $ TcCon con 212 | go (TcMetaVar meta@(TcMetaRef _name var)) = do 213 | mbVal <- liftST $ readSTRef var 214 | case mbVal of 215 | Just val -> go val 216 | Nothing -> 217 | case lookup meta vars of 218 | Nothing -> pure $ TcMetaVar meta 219 | Just ty -> pure ty 220 | go (TcUnboxedTuple tys) = TcUnboxedTuple <$> mapM go tys 221 | go (TcTuple tys) = TcTuple <$> mapM go tys 222 | go (TcList ty) = TcList <$> go ty 223 | go TcStar = pure TcStar 224 | 225 | substituteMetaVarsPred :: [(TcMetaVar s, TcType s)] -> TcPred s -> TI s (TcPred s) 226 | substituteMetaVarsPred var (TcIsIn cls ty) = 227 | TcIsIn cls <$> substituteMetaVars var ty 228 | 229 | 230 | writeMetaVar :: TcMetaVar s -> TcType s -> TI s () 231 | writeMetaVar (TcMetaRef _name var) ty = do 232 | -- debug $ "write " ++ show name ++ " = " ++ show (Doc.pretty ty) 233 | liftST $ do 234 | mbVal <- readSTRef var 235 | case mbVal of 236 | Nothing -> writeSTRef var (Just ty) 237 | Just{} -> error "writeMetaVar: Variable already set." 238 | 239 | expectAny :: ExpectedRho s -> TI s (Rho s) 240 | expectAny (Check rho) = return rho 241 | expectAny (Infer ref) = do 242 | ty <- TcMetaVar <$> newTcVar 243 | liftST $ writeSTRef ref ty 244 | return ty 245 | 246 | expectList :: ExpectedRho s -> TI s (Rho s) 247 | expectList (Check rho) = return rho 248 | expectList (Infer ref) = do 249 | ty <- TcList . TcMetaVar <$> newTcVar 250 | liftST $ writeSTRef ref ty 251 | return ty 252 | 253 | newSkolemVar :: TcVar -> TI s TcVar 254 | newSkolemVar (TcVar name _loc) = do 255 | skolems <- gets tcStateSkolems 256 | let newName = head $ filter (`Set.notMember` skolems) (name : [ name ++ show n | n <- [2..] ]) 257 | modify $ \st -> st{tcStateSkolems = Set.insert newName skolems} 258 | return $ TcSkolemVar newName 259 | newSkolemVar _ = error "expected simple tcvar" 260 | -- u <- newUnique 261 | -- return $ TcVar ("sk_" ++ show u ++ "_"++name) src 262 | 263 | -- split 264 | -- 1. simplify contexts 265 | -- 2. find predicates to defer 266 | -- 3. resolve ambiguity using defaulting 267 | -- Input: skolemized tvs and predicates 268 | -- Output: predicates to be deferred, predicates with defaulting 269 | simplifyAndDeferPredicates outer_meta preds = do 270 | preds' <- forM preds $ \predicate -> do 271 | pred_meta <- predMetaTyVars [predicate] 272 | -- debug $ "Pred_meta: " ++ show (Doc.pretty pred_meta) 273 | if not (null pred_meta) && all (`elem` outer_meta) pred_meta 274 | then return $ Left predicate 275 | else return $ Right predicate 276 | let (ds, rs) = partitionEithers preds' 277 | -- debug $ "Defer: " ++ show (Doc.pretty ds) 278 | setPredicates ds 279 | return rs 280 | 281 | renameTyVars :: [(TcVar, TcVar)] -> TcType s -> TI s (TcType s) 282 | renameTyVars vars = go 283 | where 284 | rename tv = fromMaybe tv (lookup tv vars) 285 | renamePred (TcIsIn e t) = TcIsIn e <$> go t 286 | go (TcForall tvs (TcQual preds ty)) = 287 | TcForall (map rename tvs) <$> 288 | (TcQual <$> mapM renamePred preds <*> go ty) 289 | go (TcFun a b) = TcFun <$> go a <*> go b 290 | go (TcApp a b) = TcApp <$> go a <*> go b 291 | go (TcRef var) = pure $ TcRef $ rename var 292 | go (TcCon con) = pure $ TcCon con 293 | go (TcMetaVar meta@(TcMetaRef _name var)) = do 294 | mbVal <- liftST $ readSTRef var 295 | case mbVal of 296 | Nothing -> pure $ TcMetaVar meta 297 | Just val -> go val 298 | go (TcUnboxedTuple tys) = TcUnboxedTuple <$> mapM go tys 299 | go (TcTuple tys) = TcTuple <$> mapM go tys 300 | go (TcList ty) = TcList <$> go ty 301 | go TcStar = pure TcStar 302 | 303 | renameTyVarsProof :: [(TcVar, TcVar)] -> TcProof s -> TI s (TcProof s) 304 | renameTyVarsProof vars = go 305 | where 306 | rename tv = fromMaybe tv (lookup tv vars) 307 | go (TcProofAbs tvs p) = TcProofAbs (map rename tvs) <$> go p 308 | go (TcProofAp p tys) = TcProofAp <$> go p <*> mapM (renameTyVars vars) tys 309 | go (TcProofLam n t p) = TcProofLam n <$> renameTyVars vars t <*> go p 310 | go (TcProofSrc t) = TcProofSrc <$> renameTyVars vars t 311 | go (TcProofPAp pl pr) = TcProofPAp <$> go pl <*> go pr 312 | go (TcProofVar n) = pure $ TcProofVar n 313 | 314 | {- 315 | input: 316 | Proof: ∀ 1 3. 0<1<1> → 2<3<3>> → 3<3>> 317 | Proof: 2<3<3>> 318 | Proof: 2<3<3>> 319 | 320 | output (skolems=[]): 321 | Proof: ∀ a b. a → b → b 322 | Proof: b 323 | Proof: b 324 | 325 | output (skolems=[a]): 326 | Proof: ∀ b c. b → c → c 327 | Proof: c 328 | Proof: c 329 | -} 330 | renameProofs :: TI s () 331 | renameProofs = do 332 | skolems <- gets tcStateSkolems -- :: !(Set String) 333 | proofRefs <- gets tcStateProofGroup -- :: ![STRef s (Maybe (TcProof s))] 334 | 335 | all_meta <- getFreeMetaVariables 336 | unless (null all_meta) $ error "renameProofs: Unexpected meta variables" 337 | 338 | proofs <- liftST $ map fromJust <$> mapM readSTRef proofRefs 339 | 340 | -- forM_ proofs $ \proof -> 341 | -- debug $ " Proof: " ++ show (Doc.pretty proof) 342 | 343 | usedTypes <- Set.unions <$> mapM getProofTyVars proofs 344 | 345 | let reserved = skolems `Set.union` usedTypes 346 | a_to_z = [ [c] | c <- ['a' .. 'z']] 347 | all_names = concat $ a_to_z : [ map (++show n) a_to_z | n <- [2..] ] 348 | 349 | usableNames = filter (`Set.notMember` reserved) all_names 350 | 351 | uniques <- nub . concat <$> mapM getProofUniques proofs 352 | -- debug $ "Uniques: " ++ show uniques 353 | -- debug $ "Reserved: " ++ show reserved 354 | let replace = [ (TcUniqueVar u, TcSkolemVar name) | u <- uniques | name <- usableNames ] 355 | 356 | forM_ proofRefs $ \ref -> do 357 | Just proof <- liftST $ readSTRef ref 358 | proof' <- renameTyVarsProof replace proof 359 | liftST $ writeSTRef ref (Just proof') 360 | 361 | -- FIXME: This is an inefficient hack. We want to replace numbered tcvars with named 362 | -- tcvars but not all values may have numbered tcvars in their signature. 363 | values <- gets (Map.toList . tcStateValues) 364 | forM_ values $ \(key, ty) -> do 365 | ty' <- renameTyVars replace ty 366 | setAssumption key ty' 367 | 368 | modify $ \st -> st{tcStateProofGroup = []} 369 | return () 370 | -------------------------------------------------------------------------------- /src/Language/Haskell/TypeCheck/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | module Language.Haskell.TypeCheck.Monad where 4 | 5 | import Control.Monad.Except 6 | import Control.Monad.Fail 7 | import Control.Monad.ST 8 | import Control.Monad.ST.Unsafe 9 | import Control.Monad.State 10 | import Data.Map (Map) 11 | import qualified Data.Map as Map 12 | import Data.Maybe 13 | import Data.Set (Set) 14 | import qualified Data.Set as Set 15 | import Data.STRef 16 | import Language.Haskell.Exts.SrcLoc 17 | import Language.Haskell.Exts.Syntax (Asst (..), Boxed (..), 18 | Context (..), Module, 19 | Name (..), QName (..), 20 | SpecialCon (..), 21 | TyVarBind (..), Type (..), 22 | ann) 23 | 24 | import Language.Haskell.Scope as Scope 25 | import qualified Language.Haskell.TypeCheck.Pretty as Doc 26 | import Language.Haskell.TypeCheck.Proof 27 | import Language.Haskell.TypeCheck.Types hiding (Type (..),TyVar(..)) 28 | import qualified Language.Haskell.TypeCheck.Types as T 29 | 30 | {- 31 | TcQual [] (TcIsIn Show a) 32 | class Show a 33 | 34 | TcQual [TcIsIn "Eq" a] (TcIsIn Ord a) 35 | class Eq a => Ord a 36 | 37 | TcQual [TcIsIn "Monad" m] (TcIsIn MArray a e m)] 38 | class Monad m => MArray a e m 39 | 40 | TcQual [TcIsIn "Ord" a, TcIsIn "Ord" b] (TcIsIn Ord (a,b)) 41 | instance (Ord a, Ord b) => Ord (a, b) 42 | 43 | TcQual [] (TcIsIn Ord Char) 44 | instance Ord Char 45 | 46 | classes :: TcQual s (TcPred s) 47 | instances :: TcQual s (TcPred s) 48 | 49 | API: 50 | bySuper :: TcPred s -> [TcPred s] 51 | bySuper (TcIsIn "Ord" value) = [TcIsIn "Eq" value] 52 | bySuper (TcIsIn "MArray" a e m) = [TcIsIn "Monad" m] 53 | 54 | byInst :: TcPred s -> [TcPred s] 55 | byInst (TcIsIn "Ord" (fst, snd)) = [TcIsIn "Ord" fst, TcIsIn "Ord" snd] 56 | 57 | instance Class [Char] 58 | TcIsIn Class [a] 59 | 60 | matchInstance :: TcPred s -> TcPred s -> TI s (Maybe [(TyVar, TcType s)]) 61 | 62 | preds :=> head 63 | subst <- match p head 64 | subst :: [(TyVar, TcType s)] 65 | map (applySubst subst) preds 66 | 67 | 68 | -} 69 | 70 | data TcEnv = TcEnv 71 | { tcEnvValues :: Map Entity T.Type 72 | } 73 | 74 | emptyTcEnv :: TcEnv 75 | emptyTcEnv = TcEnv { tcEnvValues = Map.empty } 76 | 77 | data TIError 78 | = UnificationError String 79 | | ContextTooWeak 80 | | MatchError 81 | | GeneralError String 82 | deriving (Show) 83 | 84 | data TcState s = TcState 85 | { -- Values such as 'length', 'Nothing', 'Just', etc 86 | tcStateValues :: !(Map Entity (TcType s)) 87 | , tcStateClasses :: !([TcQual s (TcPred s)]) 88 | , tcStateInstances :: !([TcQual s (TcPred s)]) 89 | , tcStateUnique :: !(Int) 90 | , tcStateSkolems :: !(Set String) 91 | , tcStateProofGroup :: ![STRef s (Maybe (TcProof s))] 92 | , tcStateRecursive :: !(Set Entity) 93 | -- ^ Set of recursive bindings in the current group. 94 | , tcStateKnots :: [(Entity, Pin s)] 95 | -- ^ Locations where bindings from the current group are used. This is used to set 96 | -- proper coercions after generalization. 97 | 98 | -- FIXME: We want to use a Writer for the predicates. 99 | , tcStatePredicates :: [TcPred s] 100 | } 101 | newtype TI s a = TI { unTI :: ExceptT TIError (StateT (TcState s) (ST s)) a } 102 | deriving ( Monad, MonadFail, Functor, Applicative, MonadState (TcState s) 103 | , MonadError TIError ) 104 | 105 | liftST :: ST s a -> TI s a 106 | liftST action = TI $ ExceptT $ StateT $ \env -> do 107 | a <- action 108 | return (Right a,env) 109 | 110 | instance MonadIO (TI s) where 111 | liftIO io = liftST (unsafeIOToST io) 112 | 113 | tiMaybe :: b -> (a -> TI s b) -> Maybe a -> TI s b 114 | tiMaybe def _ Nothing = pure def 115 | tiMaybe _ fn (Just a) = fn a 116 | 117 | debug :: String -> TI s () 118 | debug str = liftIO (putStrLn str) 119 | 120 | debugPP :: Doc.Pretty a => String -> a -> TI s () 121 | debugPP tag value = debug $ tag ++ ": " ++ show (Doc.pretty value) 122 | 123 | 124 | --type Infer a = a Origin -> TI (a Typed) 125 | 126 | emptyTcState :: TcState s 127 | emptyTcState = TcState 128 | { tcStateValues = Map.empty 129 | , tcStateClasses = [] 130 | , tcStateInstances = [] 131 | , tcStateUnique = 0 132 | , tcStateSkolems = Set.empty 133 | , tcStateProofGroup = [] 134 | , tcStateRecursive = Set.empty 135 | , tcStateKnots = [] 136 | , tcStatePredicates = [] 137 | } 138 | 139 | -- runTI :: forall a. TcEnv -> (forall s. TI s a) -> TcEnv 140 | -- runTI env action = runST (toEnv =<< execStateT (unTI f) st) 141 | -- where 142 | -- toEnv st = return (TcEnv Map.empty) 143 | -- st = emptyTcState 144 | -- { tcStateValues = Map.map toTcType (tcEnvValues env) } 145 | -- f = do 146 | -- action 147 | -- vars <- gets tcStateValues 148 | -- vars' <- forM (Map.assocs vars) $ \(src, ty) -> do 149 | -- ty' <- zonk ty 150 | -- return (src, ty') 151 | -- coercions <- gets tcStateCoercions 152 | -- coercions' <- forM (Map.assocs coercions) $ \(src, coerce) -> do 153 | -- coerce' <- zonkCoercion coerce 154 | -- return (src, coerce') 155 | -- -- modify $ \st -> st{tcStateValues = Map.fromList vars' 156 | -- -- ,tcStateCoercions = Map.fromList coercions'} 157 | -- return () 158 | 159 | withRecursive :: [Entity] -> TI s a -> TI s a 160 | withRecursive rec action = do 161 | original <- get 162 | modify $ \st -> st{tcStateRecursive = tcStateRecursive st `Set.union` Set.fromList rec} 163 | a <- action 164 | modify $ \st -> st{tcStateRecursive = tcStateRecursive original} 165 | return a 166 | 167 | isRecursive :: Entity -> TI s Bool 168 | isRecursive gname = gets $ Set.member gname . tcStateRecursive 169 | 170 | setKnot :: Entity -> Pin s -> TI s () 171 | setKnot gname pin = 172 | modify $ \st -> st{tcStateKnots = (gname,pin) : tcStateKnots st} 173 | 174 | getKnots :: TI s [(Entity, Pin s)] 175 | getKnots = gets tcStateKnots 176 | 177 | addPredicates :: [TcPred s] -> TI s () 178 | addPredicates predicates = 179 | modify $ \st -> st{tcStatePredicates = predicates ++ tcStatePredicates st} 180 | 181 | getPredicates :: TI s [TcPred s] 182 | getPredicates = gets tcStatePredicates 183 | 184 | setPredicates :: [TcPred s] -> TI s () 185 | setPredicates predicates = 186 | modify $ \st -> st{tcStatePredicates = predicates} 187 | 188 | dropSkolem :: TcVar -> TI s () 189 | dropSkolem (TcVar name _) = 190 | modify $ \st -> st{tcStateSkolems = Set.delete name (tcStateSkolems st) } 191 | dropSkolem (TcSkolemVar name) = 192 | modify $ \st -> st{tcStateSkolems = Set.delete name (tcStateSkolems st) } 193 | dropSkolem TcUniqueVar{} = return () 194 | 195 | newUnique :: TI s Int 196 | newUnique = do 197 | u <- gets tcStateUnique 198 | modify $ \env -> env{ tcStateUnique = u + 1 } 199 | return u 200 | 201 | -- getFreeMetaVariables :: TI s [TcMetaVar s] 202 | -- getFreeMetaVariables = do 203 | -- m <- gets tcStateValues 204 | -- nub . concat <$> mapM metaVariables (Map.elems m) 205 | 206 | setAssumption :: Entity -> TcType s -> TI s () 207 | setAssumption ident tySig = do 208 | -- debug $ "SetAssumption: " ++ show (Doc.pretty ident) ++ " :: " ++ show (Doc.pretty tySig) 209 | modify $ \env -> 210 | env{ tcStateValues = Map.insert ident tySig (tcStateValues env) } 211 | 212 | findAssumption :: Entity -> TI s (Sigma s) 213 | findAssumption ident = do 214 | m <- gets tcStateValues 215 | case Map.lookup ident m of 216 | Nothing -> error $ "Language.Haskell.TypeCheck.findAssumption: Missing ident: " ++ show ident 217 | Just scheme -> return scheme 218 | 219 | setProof :: Pin s -> TcCoercion s -> TcType s -> TI s () 220 | setProof (Pin _ ref) coercion src = do 221 | mbProof <- liftST $ readSTRef ref 222 | case mbProof of 223 | Nothing -> do 224 | -- debug $ "SetProof: " ++ show (Doc.pretty $ coercion $ TcProofSrc src) 225 | liftST $ writeSTRef ref (Just $ coercion $ TcProofSrc src) 226 | modify $ \st -> st{tcStateProofGroup = ref : tcStateProofGroup st} 227 | Just{} -> error "Proof already set" 228 | 229 | getProof :: Pin s -> TI s (TcProof s) 230 | getProof (Pin _ ref) = liftST $ do 231 | Just proof <- readSTRef ref 232 | return proof 233 | 234 | pinAST :: Module Origin -> TI s (Module (Pin s)) 235 | pinAST = liftST . traverse newPin 236 | where 237 | newPin origin = do 238 | ref <- newSTRef Nothing 239 | return $ Pin origin ref 240 | 241 | unpinAST :: Module (Pin s) -> TI s (Module Typed) 242 | unpinAST = traverse unpin 243 | where 244 | unpin (Pin (Origin nameinfo srcspan) ref) = do 245 | mbProof <- liftST $ readSTRef ref 246 | case mbProof of 247 | Nothing -> return $ Scoped nameinfo srcspan 248 | Just proof -> do 249 | -- debug (show nameinfo) 250 | zonked <- simplifyProof.simplifyProof <$> zonkProof proof 251 | pure $ Coerced nameinfo srcspan zonked 252 | -- if isTrivial zonked && not (isBinding nameinfo) 253 | -- then pure $ Scoped nameinfo srcspan 254 | -- else pure $ Coerced nameinfo srcspan zonked 255 | 256 | isBinding :: Scope.NameInfo -> Bool 257 | isBinding Scope.Binding{} = True 258 | isBinding _ = False 259 | 260 | expectResolvedPin :: Pin s -> TI s Entity 261 | expectResolvedPin (Pin (Origin (Resolved gname) _) _) = pure gname 262 | expectResolvedPin (Pin (Origin (Binding gname) _) _) = pure gname 263 | expectResolvedPin _ = throwError $ GeneralError "expected resolved" 264 | 265 | qnameToEntity :: QName (Pin s) -> TI s Entity 266 | qnameToEntity qname = 267 | case qname of 268 | Qual _src _mod name -> expectResolvedPin (ann name) 269 | UnQual _src name -> expectResolvedPin (ann name) 270 | Special _src _specialCon -> error "qnameToEntity: Special?" 271 | 272 | addClass :: TcQual s (TcPred s) -> TI s () 273 | addClass classDef = 274 | modify $ \st -> st{ tcStateClasses = classDef : tcStateClasses st } 275 | 276 | addInstance :: TcQual s (TcPred s) -> TI s () 277 | addInstance instDef = 278 | modify $ \st -> st{ tcStateInstances = instDef : tcStateInstances st } 279 | 280 | -- ass "Ord" = ([TcIsIn "Eq" a], TcRef a) 281 | -- lookupClass "Monad" = ([TcIsIn "Applicative" m], TcRef m) 282 | -- lookupClass "Show" = ([], TcRef a) 283 | lookupClass :: Entity -> TI s ([TcPred s], TcType s) 284 | lookupClass className = do 285 | clss <- gets tcStateClasses 286 | case [ (constraints, ty) 287 | | TcQual constraints (TcIsIn thisClassName ty) <- clss 288 | , thisClassName == className ] of 289 | [ ret ] -> return ret 290 | _ -> error $ "Class not found: " ++ show className 291 | 292 | -- lookupInstances "Ord" = [ ([], Int) 293 | -- , ([TcIsIn "Ord" a], Maybe a) 294 | -- , ([TcIsIn "Ord" a, TcIsIn "Ord" b], (a, b)) ] 295 | lookupInstances :: Entity -> TI s [([TcPred s], TcType s)] 296 | lookupInstances className = do 297 | insts <- gets tcStateInstances 298 | return [ (constraints, ty) 299 | | TcQual constraints (TcIsIn thisClassName ty) <- insts 300 | , thisClassName == className ] 301 | 302 | zonkTcVar :: TcVar -> T.TyVar 303 | zonkTcVar (TcVar name _loc) = T.TyVar name 304 | zonkTcVar (TcSkolemVar name) = T.TyVar name 305 | zonkTcVar (TcUniqueVar n) = T.TyVar (show n) 306 | 307 | zonkType :: TcType s -> TI s T.Type 308 | zonkType ty = do 309 | -- debug $ "Zonk: " ++ show (Doc.pretty ty) 310 | case ty of 311 | TcForall [] (TcQual [] tty) -> zonkType tty 312 | TcForall tyvars (TcQual predicates tty) -> 313 | T.TyForall (map zonkTcVar tyvars) <$> 314 | ((:=>) <$> mapM zonkPredicate predicates <*> zonkType tty) 315 | TcFun a b -> T.TyFun <$> zonkType a <*> zonkType b 316 | TcApp a b -> T.TyApp <$> zonkType a <*> zonkType b 317 | TcRef var -> pure $ T.TyRef $ zonkTcVar var 318 | TcCon con -> pure $ T.TyCon con 319 | TcMetaVar (TcMetaRef name meta) -> do 320 | mbTy <- liftST (readSTRef meta) 321 | case mbTy of 322 | Nothing -> error $ "Zonking unset meta variable: " ++ show name 323 | Just sub -> zonkType sub 324 | TcUnboxedTuple tys -> T.TyUnboxedTuple <$> mapM zonkType tys 325 | TcTuple tys -> T.TyTuple <$> mapM zonkType tys 326 | TcList elt -> T.TyList <$> zonkType elt 327 | TcStar -> pure T.TyStar 328 | 329 | zonkPredicate :: TcPred s -> TI s Predicate 330 | zonkPredicate (TcIsIn className ty) = IsIn className <$> zonkType ty 331 | 332 | zonkProof :: TcProof s -> TI s Proof 333 | zonkProof proof = 334 | case proof of 335 | TcProofAbs tvs p -> ProofAbs (map zonkTcVar tvs) <$> zonkProof p 336 | TcProofAp p tys -> ProofAp <$> zonkProof p <*> mapM zonkType tys 337 | TcProofLam n ty p -> ProofLam n <$> zonkType ty <*> zonkProof p 338 | TcProofSrc ty -> ProofSrc <$> zonkType ty 339 | TcProofPAp p1 p2 -> ProofPAp <$> zonkProof p1 <*> zonkProof p2 340 | TcProofVar n -> pure $ ProofVar n 341 | 342 | tcVarFromName :: Name (Pin s) -> TcVar 343 | tcVarFromName name = 344 | TcVar ident src 345 | where 346 | src = case ann name of 347 | Pin (Origin (Resolved entity) _) _ -> entityLocation entity 348 | Pin (Origin (Binding entity) _) _ -> entityLocation entity 349 | _ -> [] 350 | ident = 351 | case name of 352 | Symbol _ symbol -> symbol 353 | Ident _ ident -> ident 354 | 355 | newTcVar :: TI s (TcMetaVar s) 356 | newTcVar = do 357 | u <- newUnique 358 | ref <- liftST $ newSTRef Nothing 359 | return $ TcMetaRef u ref 360 | 361 | typeToTcType :: Type (Pin s) -> TI s (TcType s) 362 | typeToTcType ty = 363 | case ty of 364 | TyForall _ mbTybinds mbContext ty' -> 365 | TcForall 366 | [ case bind of 367 | KindedVar _ name _kind -> tcVarFromName name 368 | UnkindedVar _ name -> tcVarFromName name | bind <- fromMaybe [] mbTybinds ] 369 | <$> (TcQual <$> tiMaybe [] contextToPredicates mbContext <*> typeToTcType ty') 370 | TyFun _ a b -> TcFun <$> typeToTcType a <*> typeToTcType b 371 | TyVar _ name -> pure $ TcRef (tcVarFromName name) 372 | TyCon _ (Special _ UnitCon{}) -> 373 | pure $ TcTuple [] 374 | TyCon _ qname -> do 375 | entity <- qnameToEntity qname 376 | pure $ TcCon $ entityName entity 377 | TyApp _ a b -> TcApp <$> typeToTcType a <*> typeToTcType b 378 | TyParen _ t -> typeToTcType t 379 | TyTuple _ Unboxed tys -> TcUnboxedTuple <$> mapM typeToTcType tys 380 | TyTuple _ Boxed tys -> TcTuple <$> mapM typeToTcType tys 381 | TyList _ elt -> TcList <$> typeToTcType elt 382 | _ -> error $ "typeToTcType: " ++ show ty 383 | 384 | contextToPredicates :: Context (Pin s) -> TI s [TcPred s] 385 | contextToPredicates ctx = 386 | case ctx of 387 | CxEmpty{} -> pure [] 388 | CxSingle _origin asst -> pure <$> assertionToPredicate asst 389 | CxTuple _origin assts -> mapM assertionToPredicate assts 390 | 391 | assertionToPredicate :: Asst (Pin s) -> TI s (TcPred s) 392 | assertionToPredicate asst = 393 | case asst of 394 | ParenA _ sub -> assertionToPredicate sub 395 | ClassA _ qname [ty] -> 396 | TcIsIn <$> qnameToEntity qname <*> typeToTcType ty 397 | ClassA _ _qname [] -> error "assertionToPredicate: MultiParamTypeClasses not supported" 398 | _ -> error "assertionToPredicate: unsupported assertion" 399 | 400 | --tcTypeToScheme :: TcType -> TcType 401 | --tcTypeToScheme ty = Scheme (freeTcVariables ty) ([] :=> ty) 402 | 403 | -- freeTcVariables :: TcType s -> [TcVar] 404 | -- freeTcVariables = nub . worker [] 405 | -- where 406 | -- worker ignore ty = 407 | -- case ty of 408 | -- TcForall{} -> error "freeTcVariables" 409 | -- TcFun a b -> worker ignore a ++ worker ignore b 410 | -- TcApp a b -> worker ignore a ++ worker ignore b 411 | -- TcRef v | v `elem` ignore -> [] 412 | -- | otherwise -> [v] 413 | -- TcCon{} -> [] 414 | -- TcUnboxedTuple tys -> concatMap (worker ignore) tys 415 | -- TcMetaVar{} -> [] 416 | -- TcTuple tys -> concatMap (worker ignore) tys 417 | -- TcList elt -> worker ignore elt 418 | 419 | -- metaVariables :: TcType s -> TI s [TcMetaVar s] 420 | -- metaVariables ty = 421 | -- case ty of 422 | -- -- XXX: There shouldn't be any meta variables inside a forall scope. 423 | -- TcForall _ (TcQual _ ty') -> metaVariables ty' 424 | -- TcFun a b -> (++) <$> metaVariables a <*> metaVariables b 425 | -- TcApp a b -> (++) <$> metaVariables a <*> metaVariables b 426 | -- TcRef{} -> pure [] 427 | -- TcCon{} -> pure [] 428 | -- TcMetaVar var@(TcMetaRef _ ref) -> do 429 | -- mbTy <- liftST $ readSTRef ref 430 | -- case mbTy of 431 | -- Just ty' -> metaVariables ty' 432 | -- Nothing -> return [var] 433 | -- TcUnboxedTuple tys -> concat <$> mapM metaVariables tys 434 | -- TcTuple tys -> concat <$> mapM metaVariables tys 435 | -- TcList elt -> metaVariables elt 436 | 437 | -- Replace free meta vars with tcvars. Compute the smallest context. 438 | -- 439 | -- generalize :: [TcMetaVar s] -> TcType s -> TI s (TcType s, Coercion s) 440 | -- generalize free ty = do 441 | -- meta <- metaVariables ty 442 | -- let unbound = nub meta \\ free 443 | -- forM_ unbound $ \var@(TcMetaRef _name ref) -> 444 | -- liftST $ writeSTRef ref (Just (TcRef (toTcVar var))) 445 | -- -- ty' <- zonk ty 446 | -- let tcVars = map toTcVar unbound 447 | -- return ( TcForall tcVars (TcQual [] ty), CoerceAbs tcVars) 448 | -- where 449 | -- toTcVar (TcMetaRef name _) = TcVar name noSrcSpanInfo 450 | 451 | noSrcSpanInfo :: SrcSpanInfo 452 | noSrcSpanInfo = infoSpan (mkSrcSpan noLoc noLoc) [] 453 | 454 | -- mkBuiltIn moduleName identifier 455 | mkBuiltIn :: String -> String -> QualifiedName 456 | mkBuiltIn = QualifiedName 457 | -------------------------------------------------------------------------------- /src/Language/Haskell/TypeCheck/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Language.Haskell.TypeCheck.Pretty 2 | ( Pretty(..) 3 | , parensIf 4 | , module Text.PrettyPrint.ANSI.Leijen 5 | ) where 6 | 7 | import Text.PrettyPrint.ANSI.Leijen hiding (Pretty(..)) 8 | 9 | class Pretty a where 10 | prettyPrec :: Int -> a -> Doc 11 | prettyPrec _ = pretty 12 | pretty :: a -> Doc 13 | pretty = prettyPrec 0 14 | {-# MINIMAL prettyPrec | pretty #-} 15 | 16 | instance Pretty a => Pretty [a] where 17 | prettyPrec _ = list . map pretty 18 | 19 | parensIf :: Bool -> Doc -> Doc 20 | parensIf True = parens 21 | parensIf False = id 22 | -------------------------------------------------------------------------------- /src/Language/Haskell/TypeCheck/Proof.hs: -------------------------------------------------------------------------------- 1 | module Language.Haskell.TypeCheck.Proof where 2 | 3 | import Language.Haskell.TypeCheck.Types 4 | 5 | tcProofAbs :: [TcVar] -> TcProof s -> TcProof s 6 | tcProofAbs [] x = x 7 | tcProofAbs lst (TcProofAp x lst') | map TcRef lst == lst' = x 8 | tcProofAbs lst x = TcProofAbs lst x 9 | 10 | tcProofAp :: TcProof s -> [TcType s] -> TcProof s 11 | tcProofAp x [] = x 12 | tcProofAp x lst = TcProofAp x lst 13 | 14 | tcProofLam :: Int -> TcType s -> TcProof s -> TcProof s 15 | tcProofLam a _ty (TcProofPAp x (TcProofVar b)) | a == b = x 16 | tcProofLam a ty p = TcProofLam a ty p 17 | 18 | simplifyProof :: Proof -> Proof 19 | simplifyProof (ProofAp (ProofAp x lst) lst') = 20 | simplifyProof $ ProofAp x (lst ++ lst') 21 | simplifyProof (ProofSrc (TyForall [] ([] :=> ty))) = simplifyProof (ProofSrc ty) 22 | simplifyProof (ProofAbs lst (ProofAp x lst')) 23 | | map TyRef lst == lst' = simplifyProof x 24 | simplifyProof (ProofAp (ProofAbs lst p) lst') 25 | | map TyRef lst == lst' = simplifyProof p 26 | simplifyProof (ProofLam n ty p) = 27 | case simplifyProof p of 28 | ProofPAp p' (ProofVar n') 29 | | n == n' -> p' 30 | p' -> ProofLam n ty p' 31 | simplifyProof (ProofAbs tvs p) = ProofAbs tvs (simplifyProof p) 32 | simplifyProof (ProofAp p ty) = ProofAp (simplifyProof p) ty 33 | simplifyProof (ProofSrc ty) = ProofSrc ty 34 | simplifyProof (ProofPAp p1 p2) = ProofPAp (simplifyProof p1) (simplifyProof p2) 35 | simplifyProof (ProofVar n) = ProofVar n 36 | 37 | isTrivial :: Proof -> Bool 38 | -- isTrivial (ProofSrc (TyForall [] ([] :=> ty))) = isTrivial (ProofSrc ty) 39 | isTrivial (ProofSrc TyForall{}) = False 40 | isTrivial ProofSrc{} = True 41 | isTrivial _ = False 42 | 43 | 44 | -- Proof -> Type 45 | reifyProof :: Proof -> Type 46 | reifyProof (ProofSrc ty) = ty 47 | reifyProof (ProofAbs tvs p) = TyForall tvs ([] :=> reifyProof p) 48 | reifyProof _ = undefined 49 | -------------------------------------------------------------------------------- /src/Language/Haskell/TypeCheck/Subsumption.hs: -------------------------------------------------------------------------------- 1 | module Language.Haskell.TypeCheck.Subsumption where 2 | 3 | import Language.Haskell.TypeCheck.Types 4 | import Language.Haskell.TypeCheck.Monad 5 | import Language.Haskell.TypeCheck.Misc 6 | import Language.Haskell.TypeCheck.Unify 7 | import Language.Haskell.TypeCheck.Proof 8 | 9 | import Control.Monad 10 | import Data.List 11 | import Data.STRef 12 | 13 | -- coercion :: sigma -> rho 14 | instantiate :: Sigma s -> TI s (Rho s, TcCoercion s) 15 | instantiate (TcForall [] (TcQual [] ty)) = do 16 | -- debug $ "Instatiate: Silly forall" 17 | instantiate ty 18 | instantiate (TcForall tvs (TcQual preds ty)) = do 19 | tvs' <- map TcMetaVar <$> replicateM (length tvs) newTcVar 20 | ty' <- substituteTyVars (zip tvs tvs') ty 21 | preds' <- forM preds $ mapTcPredM (substituteTyVars (zip tvs tvs')) 22 | -- debug $ "Instantiate: " ++ show (P.pretty orig) ++ " => " ++ show (P.pretty ty') 23 | addPredicates preds' 24 | return (ty', \x -> tcProofAp x tvs') 25 | -- instantiate TcForall{} = error "instantiate: Predicate not supported yet." 26 | instantiate tau = return (tau, id) 27 | 28 | instantiateMethod :: Sigma s -> TcVar -> Sigma s 29 | instantiateMethod (TcForall tvs (TcQual pred ty)) tv = 30 | TcForall (delete tv tvs) (TcQual [ elt | elt@(TcIsIn _cls (TcRef pTV)) <- pred, pTV /= tv ] ty) 31 | instantiateMethod sigma _tv = sigma 32 | 33 | {- 34 | skolemize sigma = /\a.rho + f::/\a.rho -> sigma 35 | 36 | Skolemize hoists all forall's to the top-level and returns a coercion function 37 | from the new sigma type to the old sigma type. 38 | -} 39 | skolemize :: Sigma s -> TI s ([TcVar], [TcPred s], Rho s, TcCoercion s) 40 | skolemize (TcForall tvs (TcQual preds ty)) = do 41 | sks <- mapM newSkolemVar tvs 42 | -- debug $ "New Skolem: " ++ show (P.pretty sks) 43 | let skTys = map TcRef sks 44 | (sks2, preds2, ty', f) <- skolemize =<< substituteTyVars (zip tvs skTys) ty 45 | preds' <- forM preds $ mapTcPredM (substituteTyVars (zip tvs skTys)) 46 | return (sks ++ sks2, preds' ++ preds2, ty', \x -> tcProofAbs sks $ f (x `tcProofAp` skTys)) 47 | skolemize (TcFun arg_ty res_ty) = do 48 | (sks, preds, res_ty', f) <- skolemize res_ty 49 | u <- newUnique 50 | return ( sks, preds, TcFun arg_ty res_ty' 51 | , \x -> tcProofLam u arg_ty $ f $ 52 | tcProofAbs sks $ ((x `tcProofAp` map TcRef sks) `TcProofPAp` TcProofVar u)) 53 | skolemize ty = 54 | return ([], [], ty, id) 55 | 56 | -- quantify [a] [] (a -> b) = forall a. a -> b 57 | -- quantify [b] [] (a -> b) = forall b. a -> b 58 | -- quantify [c] [] (a -> b) = a -> b 59 | quantify :: [TcVar] -> [TcPred s] -> Rho s -> TI s (Sigma s, [TcVar]) 60 | quantify tvs predicates rho = do 61 | rho_tvs <- getFreeTyVars [rho] 62 | let local = tvs `intersect` rho_tvs 63 | return (TcForall local (TcQual predicates rho), local) 64 | 65 | 66 | checkRho :: (ExpectedRho s -> TI s ()) -> Rho s -> TI s () 67 | checkRho action ty = action (Check ty) 68 | 69 | inferRho :: (ExpectedRho s -> TI s ()) -> TI s (Rho s) 70 | inferRho action = do 71 | ref <- liftST $ newSTRef (error "inferRho: empty result") 72 | action (Infer ref) 73 | liftST $ readSTRef ref 74 | 75 | checkSigma :: (ExpectedRho s -> TI s ()) -> Sigma s -> TI s () 76 | checkSigma action sigma = do 77 | -- debug $ "CheckSigma: " ++ show (P.pretty sigma) 78 | -- (rho, _rhoToSigma) <- instantiate sigma 79 | (_skol_tvs, _preds, rho, _prenexToSigma) <- skolemize sigma 80 | checkRho action rho 81 | -- env_tys <- getEnvTypes 82 | -- esc_tvs <- getFreeTyVars (sigma : env_tys) 83 | -- let bad_tvs = filter (`elem` esc_tvs) skol_tvs 84 | -- unless (null bad_tvs) $ error $ "Type not polymorphic enough: " ++ show (P.pretty bad_tvs) 85 | -- let coercion = tcProofAbs skol_tvs 86 | -- setProof pin rhoToSigma rho 87 | 88 | -- Rule DEEP-SKOL 89 | -- subsCheck offered_type expected_type 90 | -- coercion :: Sigma1 -> Sigma2 91 | subsCheck :: Sigma s -> Sigma s -> TI s (TcCoercion s) 92 | subsCheck sigma1 sigma2 = do 93 | -- debug $ "subsCheck: " ++ show (P.pretty sigma1) ++ " >> " ++ show (P.pretty sigma2) 94 | (skol_tvs, _preds, rho2, forallrho2ToSigma2) <- skolemize sigma2 95 | sigma1ToRho2 <- subsCheckRho sigma1 rho2 96 | esc_tvs <- getFreeTyVars [sigma1, sigma2] 97 | let bad_tvs = filter (`elem` esc_tvs) skol_tvs 98 | unless (null bad_tvs) $ error $ "Subsumption check failed: " ++ show bad_tvs 99 | -- /\a.rho = sigma2 100 | -- \sigma1 -> forallrho2ToSigma2 (/\a. sigma1ToRho2 sigma1) 101 | -- return (CoerceCompose (CoerceAbs skol_tvs) sigma2ToRho2) 102 | return $ \x -> forallrho2ToSigma2 (tcProofAbs skol_tvs (sigma1ToRho2 x)) 103 | 104 | -- instSigma ((forall a. a -> a) -> Int) ((forall a b. a -> b) -> Int) 105 | -- = CoerceFun Id (subsCheck (forall a b. a -> b) (forall a. a -> a)) 106 | -- subsCheck (forall a b. a -> b) (forall a. a -> a) 107 | -- = Compose (Abs [a]) (subsCheckRho (forall a b. a -> b) (a -> a)) 108 | -- = Compose (Abs [a]) (Compose Id (Ap [a,b])) 109 | 110 | -- (forall ab. a -> b) (a -> a) = Compose (subsCheckRho (a -> b) (a -> a)) (Ap [a,b]) 111 | -- subsCheckRho (a -> b) (a -> a) = CoerceFun (subCheckRho b a) (subsCheck a a) = CoerceFun Id Id 112 | -- subsCheckRho tau tau = Id 113 | subsCheckRho :: Sigma s -> Rho s -> TI s (TcCoercion s) 114 | subsCheckRho sigma1@TcForall{} rho2 = do 115 | (rho1, sigma1ToRho1) <- instantiate sigma1 116 | rho1ToRho2 <- subsCheckRhoRho rho1 rho2 117 | let sigma1ToRho2 = rho1ToRho2 . sigma1ToRho1 118 | return sigma1ToRho2 119 | subsCheckRho t1 t2 = subsCheckRhoRho t1 t2 120 | 121 | -- coercion :: rho1 -> rho2 122 | subsCheckRhoRho :: Rho s -> Rho s -> TI s (TcCoercion s) 123 | subsCheckRhoRho (TcFun a1 r1) t2 = do 124 | (a2, r2) <- unifyFun t2 125 | subsCheckFun a1 r1 a2 r2 126 | subsCheckRhoRho t1 (TcFun a2 r2) = do 127 | (a1, r1) <- unifyFun t1 128 | subsCheckFun a1 r1 a2 r2 129 | subsCheckRhoRho t1 t2 = do 130 | unify t1 t2 131 | return id 132 | 133 | -- subsCheckFun (a1 -> r1) (a2 -> r2) 134 | -- coercion :: (a1 -> r1) -> (a2 -> r2) 135 | subsCheckFun :: Sigma s -> Rho s -> Sigma s -> Rho s -> TI s (TcCoercion s) 136 | subsCheckFun a1 r1 a2 r2 = do 137 | co_arg <- subsCheck a2 a1 138 | -- co_arg :: a2 -> a1 139 | co_res <- subsCheckRho r1 r2 140 | -- co_res :: r1 -> r2 141 | u <- newUnique 142 | return $ \x -> tcProofLam u a2 (co_res (x `TcProofPAp` co_arg (TcProofVar u))) 143 | 144 | 145 | 146 | -- We have type 'Sigma' and we want type 'Rho'. The coercion is a function of 147 | -- type Sigma->Rho 148 | instSigma :: Sigma s -> Expected s (Rho s) -> TI s (TcCoercion s) 149 | instSigma ty (Infer r) = do 150 | (ty', coerce) <- instantiate ty 151 | liftST $ writeSTRef r ty' 152 | return coerce 153 | instSigma ty (Check rho) = subsCheckRho ty rho 154 | -------------------------------------------------------------------------------- /src/Language/Haskell/TypeCheck/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | -- Syntax-directed typing rules. 2 | module Language.Haskell.TypeCheck.SyntaxDirected where 3 | 4 | 5 | import Control.Monad 6 | import Control.Monad.Except 7 | import Data.Graph (flattenSCC, 8 | stronglyConnComp) 9 | import Data.List 10 | import Data.Maybe 11 | import Data.STRef 12 | import Language.Haskell.Exts.SrcLoc 13 | import Language.Haskell.Exts.Syntax 14 | import qualified Language.Haskell.Exts.Pretty as HS 15 | 16 | import Language.Haskell.Scope (Entity (..), 17 | NameInfo (..), 18 | Origin (..)) 19 | import Language.Haskell.TypeCheck.Misc 20 | import Language.Haskell.TypeCheck.Monad 21 | import Language.Haskell.TypeCheck.Proof 22 | import Language.Haskell.TypeCheck.Subsumption 23 | import Language.Haskell.TypeCheck.Types hiding (Type (..), 24 | Typed (..)) 25 | import Language.Haskell.TypeCheck.Unify 26 | 27 | -- import qualified Language.Haskell.TypeCheck.Pretty as Doc 28 | 29 | -- tiGuardedAlts :: GuardedAlts Origin -> TI TcType 30 | -- tiGuardedAlts galts = 31 | -- case galts of 32 | -- UnGuardedAlt _ branch -> tiExp branch 33 | -- _ -> error "tiGuardedAlts" 34 | 35 | tiAlt :: Rho s -> ExpectedRho s -> Alt (Pin s) -> TI s () 36 | tiAlt scrutTy exp_ty (Alt _ pat rhs _mbBinds) = do 37 | checkRho (tiPat pat) scrutTy 38 | tiRhs rhs exp_ty 39 | 40 | tiLit :: Literal (Pin s) -> ExpectedRho s -> TI s () 41 | tiLit lit exp_ty = do 42 | ty <- case lit of 43 | PrimInt{} -> return (TcCon (mkBuiltIn "LHC.Prim" "I64")) 44 | PrimString{} -> return $ TcApp 45 | (TcCon (mkBuiltIn "LHC.Prim" "Addr")) 46 | (TcCon (mkBuiltIn "LHC.Prim" "I8")) 47 | PrimChar{} -> return $ TcCon (mkBuiltIn "LHC.Prim" "I32") 48 | Int{} -> return $ TcCon (mkBuiltIn "LHC.Prim" "Int") 49 | Char{} -> return $ TcCon (mkBuiltIn "LHC.Prim" "Char") 50 | String{} -> return $ TcList $ TcCon (mkBuiltIn "LHC.Prim" "Char") 51 | _ -> unhandledSyntax "tiLit" lit 52 | unifyExpected ty exp_ty 53 | -- Hm, what to do with the proof here. We need it for overloaded constants 54 | -- such as numbers and Strings (iff OverloadedStrings enabled). 55 | -- For now we can just ignore it. 56 | return () 57 | 58 | -- tiQOp :: QOp Origin -> TI s (TcType s) 59 | -- tiQOp op = 60 | -- case op of 61 | -- QVarOp src var -> tiExp (Var src var) 62 | -- QConOp src con -> tiExp (Con src con) 63 | 64 | tiStmts :: [Stmt (Pin s)] -> Expected s (Rho s) -> TI s () 65 | tiStmts [] _exp_ty = error "tiStmts: empty list" 66 | tiStmts [stmt] exp_ty = 67 | case stmt of 68 | Generator{} -> unhandledSyntax "tiStmts" stmt 69 | Qualifier _ expr -> tiExp expr exp_ty 70 | _ -> unhandledSyntax "tiStmts" stmt 71 | tiStmts (stmt:stmts) exp_ty = 72 | case stmt of 73 | -- pat :: a 74 | -- expr :: IO a 75 | -- exp_ty :: IO b 76 | -- bindIO :: IO a -> (a -> IO b) -> IO b 77 | Generator pin pat expr -> do 78 | (bindIORho, proof) <- instantiate bindIOSig 79 | (ioA, _aIOb, res_ty) <- unifyFun2 bindIORho 80 | (_io, a) <- unifyApp ioA 81 | 82 | checkSigma (tiPat pat) a 83 | checkSigma (tiExp expr) ioA 84 | unifyExpected res_ty exp_ty 85 | 86 | setProof pin proof bindIOSig 87 | 88 | tiStmts stmts exp_ty 89 | 90 | -- expr :: IO a 91 | -- thenIO :: IO a -> IO b -> IO b 92 | -- exp_ty :: IO b 93 | Qualifier pin expr -> do 94 | (thenIORho, proof) <- instantiate thenIOSig 95 | (ioA, _aIOb, res_ty) <- unifyFun2 thenIORho 96 | 97 | checkSigma (tiExp expr) ioA 98 | unifyExpected res_ty exp_ty 99 | 100 | setProof pin proof thenIOSig 101 | 102 | tiStmts stmts exp_ty 103 | 104 | -- Generator _ pat expr -> do 105 | -- patTy <- inferRho (tiPat pat) 106 | -- let ioPatTy = ioType `TcApp` patTy 107 | -- let pin = ann expr 108 | -- checkSigma (ann expr) (tiExp expr) ioPatTy 109 | -- (bindIORho, proof) <- instantiate bindIOSig 110 | -- tiStmts stmts exp_ty 111 | -- Qualifier _ expr -> do 112 | -- ty <- TcMetaVar <$> newTcVar 113 | -- let ioTy = ioType `TcApp` ty 114 | -- checkRho (tiExp expr) ioTy 115 | -- tiStmts stmts exp_ty 116 | _ -> unhandledSyntax "tiStmts" stmt 117 | 118 | consSigma :: TcType s 119 | consSigma = TcForall [aRef] (TcQual [] (aTy `TcFun` (TcList aTy `TcFun` TcList aTy))) 120 | where 121 | aRef = TcVar "a" [] 122 | aTy = TcRef aRef 123 | 124 | listSigma :: TcType s 125 | listSigma = TcForall [aRef] (TcQual [] (TcList aTy)) 126 | where 127 | aRef = TcVar "a" [] 128 | aTy = TcRef aRef 129 | 130 | -- forall a b. IO a -> IO b -> IO b 131 | thenIOSig :: TcType s 132 | thenIOSig = TcForall [aRef, bRef] (TcQual [] (ioA `TcFun` (ioB `TcFun` ioB))) 133 | where 134 | aRef = TcVar "a" [] 135 | bRef = TcVar "b" [] 136 | ioA = ioType `TcApp` TcRef aRef 137 | ioB = ioType `TcApp` TcRef bRef 138 | 139 | -- forall a b. IO a -> (a -> IO b) -> IO b 140 | bindIOSig :: TcType s 141 | bindIOSig = TcForall [aRef, bRef] (TcQual [] (ioA `TcFun` ((TcRef aRef `TcFun` ioB) `TcFun` ioB))) 142 | where 143 | aRef = TcVar "a" [] 144 | bRef = TcVar "b" [] 145 | ioA = ioType `TcApp` TcRef aRef 146 | ioB = ioType `TcApp` TcRef bRef 147 | 148 | ioType :: TcType s 149 | ioType = TcCon (mkBuiltIn "LHC.Prim" "IO") 150 | 151 | tiQName :: QName (Pin s) -> Expected s (Rho s) -> TI s () 152 | tiQName (Special _ UnitCon{}) exp_ty = unifyExpected (TcTuple []) exp_ty 153 | tiQName (Special pin Cons{}) exp_ty = do 154 | coercion <- instSigma consSigma exp_ty 155 | setProof pin coercion consSigma 156 | tiQName Special{} _exp_ty = error "unhandled special" 157 | tiQName Qual{} _exp_ty = error "unhandled qual" 158 | tiQName (UnQual _src name) exp_ty = do 159 | let pin = ann name 160 | gname <- expectResolvedPin pin 161 | tySig <- findAssumption gname 162 | -- debug $ "Var: " ++ show (P.pretty tySig) 163 | coercion <- instSigma tySig exp_ty 164 | -- Proofs for recursive variables are set once all the mutually recursive 165 | -- variables have been type checked. Thus, instead of setting the proof 166 | -- now, we just note down the location (pin) and add the proof later. 167 | isRec <- isRecursive gname 168 | if isRec 169 | then setKnot gname pin 170 | else setProof pin coercion tySig 171 | 172 | tiExp :: Exp (Pin s) -> Expected s (Rho s) -> TI s () 173 | tiExp expr exp_ty = 174 | case expr of 175 | Case _ scrut alts -> do 176 | scrutTy <- inferRho (tiExp scrut) 177 | mapM_ (tiAlt scrutTy exp_ty) alts 178 | Var _ qname -> tiQName qname exp_ty 179 | Con _ (Special _ UnitCon{}) -> unifyExpected (TcTuple []) exp_ty 180 | Con _ (Special pin Cons{}) -> do 181 | coercion <- instSigma consSigma exp_ty 182 | setProof pin coercion consSigma 183 | Con _ conName -> tiQName conName exp_ty 184 | -- Con _ conName -> do 185 | -- let pin = ann conName 186 | -- gname <- qnameToGlobalName conName 187 | -- tySig <- findAssumption gname 188 | -- coercion <- instSigma tySig exp_ty 189 | -- setProof pin coercion tySig 190 | InfixApp _ a (QConOp _ qname) b -> do 191 | fnTy <- inferRho (tiQName qname) 192 | (a_ty, b_ty, res_ty) <- unifyFun2 fnTy 193 | checkSigma (tiExp a) a_ty 194 | checkSigma (tiExp b) b_ty 195 | unifyExpected res_ty exp_ty 196 | InfixApp _ a (QVarOp _ qname) b -> do 197 | fnTy <- inferRho (tiQName qname) 198 | (a_ty, b_ty, res_ty) <- unifyFun2 fnTy 199 | checkSigma (tiExp a) a_ty 200 | checkSigma (tiExp b) b_ty 201 | unifyExpected res_ty exp_ty 202 | -- a `fn` b :: exp_ty 203 | -- fn :: a -> b -> exp_ty 204 | App _ fn a -> do 205 | fnT <- inferRho (tiExp fn) 206 | (arg_ty, res_ty) <- unifyFun fnT 207 | -- debug $ "ArgTy: " ++ show (P.pretty arg_ty) 208 | checkSigma (tiExp a) arg_ty 209 | 210 | unifyExpected res_ty exp_ty 211 | -- InfixApp _ a op b -> do 212 | -- ty <- TcMetaVar <$> newTcVar 213 | -- opT <- tiQOp op 214 | -- aT <- tiExp a 215 | -- bT <- tiExp b 216 | -- unify (TcFun aT (TcFun bT ty)) opT 217 | -- return ty 218 | Paren _ e -> tiExp e exp_ty 219 | -- -- \a b c -> d 220 | -- -- :: a -> b -> c -> d 221 | Lambda _ pats e | Check rho <- exp_ty -> do 222 | -- debug $ "CheckLambda: " ++ show (P.pretty rho) 223 | (patTys, resTy) <- unifyFuns (length pats) rho 224 | forM_ (zip patTys pats) $ \(patTy, pat) -> checkRho (tiPat pat) patTy 225 | checkRho (tiExp e) resTy 226 | Lambda _ pats e | Infer ref <- exp_ty -> do 227 | patTys <- forM pats $ inferRho . tiPat 228 | resTy <- inferRho (tiExp e) 229 | liftST $ writeSTRef ref (foldr TcFun resTy patTys) 230 | Lit _ lit -> tiLit lit exp_ty 231 | Tuple _ Unboxed args | Check rho <- exp_ty -> do 232 | argTys <- unifyUnboxedTuple (length args) rho 233 | forM_ (zip argTys args) $ \(argTy,arg) -> checkRho (tiExp arg) argTy 234 | Tuple _ Unboxed args | Infer ref <- exp_ty -> do 235 | argTys <- forM args $ inferRho . tiExp 236 | liftST $ writeSTRef ref (TcUnboxedTuple argTys) 237 | Tuple _ Boxed args | Check rho <- exp_ty -> do 238 | argTys <- unifyTuple (length args) rho 239 | forM_ (zip argTys args) $ \(argTy,arg) -> checkRho (tiExp arg) argTy 240 | Let _ binds subExpr -> do 241 | tiBinds binds 242 | tiExp subExpr exp_ty 243 | List pin exprs -> do 244 | eltTy <- unifyList =<< expectList exp_ty 245 | setProof pin (`TcProofAp` [eltTy]) listSigma 246 | forM_ exprs $ \expr' -> checkRho (tiExp expr') eltTy 247 | Do _ stmts -> tiStmts stmts exp_ty 248 | _ -> unhandledSyntax "tiExp" expr 249 | 250 | findConAssumption :: QName (Pin s) -> TI s (TcType s) 251 | findConAssumption qname = case qname of 252 | Special _ con -> case con of 253 | UnitCon{} -> return (TcTuple []) 254 | ListCon{} -> do 255 | ty <- TcMetaVar <$> newTcVar 256 | return $ TcList ty 257 | Cons{} -> do 258 | ty <- TcMetaVar <$> newTcVar 259 | return $ ty `TcFun` (TcList ty `TcFun` TcList ty) 260 | _ -> unhandledSyntax "findConAssumption" qname 261 | _ -> do 262 | gname <- qnameToEntity qname 263 | findAssumption gname 264 | 265 | tiPat :: Pat (Pin s) -> ExpectedRho s -> TI s () 266 | tiPat thisPat exp_ty = 267 | case thisPat of 268 | PVar _ name -> do 269 | let pin = ann name 270 | gname <- expectResolvedPin pin 271 | ty <- expectAny exp_ty 272 | setAssumption gname ty 273 | setProof pin id ty 274 | -- con :: p1 -> p2 -> ... -> ret 275 | -- con pat1 pat2 ... 276 | PApp _ con pats -> do 277 | conSig <- findConAssumption con 278 | (conTy, coercion) <- instantiate conSig 279 | (patTys, retTy) <- unifyFuns (length pats) conTy 280 | forM_ (zip patTys pats) $ \(patTy, pat) -> checkRho (tiPat pat) patTy 281 | unifyExpected retTy exp_ty 282 | setProof (ann con) coercion conSig 283 | PWildCard _ -> return () 284 | PParen _ sub -> tiPat sub exp_ty 285 | PTuple _ Boxed pats -> do 286 | ty <- expectAny exp_ty 287 | patTys <- unifyTuple (length pats) ty 288 | forM_ (zip patTys pats) $ \(patTy, pat) -> checkRho (tiPat pat) patTy 289 | PTuple _ Unboxed pats -> do 290 | ty <- expectAny exp_ty 291 | patTys <- unifyUnboxedTuple (length pats) ty 292 | forM_ (zip patTys pats) $ \(patTy, pat) -> checkRho (tiPat pat) patTy 293 | PLit _ _sign literal -> 294 | tiLit literal exp_ty 295 | PList _ pats -> do 296 | eltTy <- unifyList =<< expectList exp_ty 297 | forM_ pats $ \pat' -> checkRho (tiPat pat') eltTy 298 | PInfixApp _ a con b -> do 299 | conSig <- findConAssumption con 300 | (conTy, coercion) <- instantiate conSig 301 | (patTys, retTy) <- unifyFuns 2 conTy 302 | forM_ (zip patTys [a,b]) $ \(patTy, pat) -> checkRho (tiPat pat) patTy 303 | unifyExpected retTy exp_ty 304 | setProof (ann con) coercion conSig 305 | _ -> unhandledSyntax "tiPat" thisPat 306 | 307 | tiRhs :: Rhs (Pin s) -> ExpectedRho s -> TI s () 308 | tiRhs rhs exp_ty = 309 | case rhs of 310 | UnGuardedRhs _ expr -> 311 | tiExp expr exp_ty 312 | _ -> unhandledSyntax "tiRhs" rhs 313 | 314 | tiMatch :: Match (Pin s) -> ExpectedRho s -> TI s () 315 | tiMatch match exp_ty = 316 | case match of 317 | Match _ _ pats rhs mbBinds -> do 318 | ty <- expectAny exp_ty 319 | (patTys, retTy) <- unifyFuns (length pats) ty 320 | forM_ (zip patTys pats) $ \(patTy, pat) -> checkRho (tiPat pat) patTy 321 | maybe (return ()) tiBinds mbBinds 322 | checkRho (tiRhs rhs) retTy 323 | InfixMatch _ leftPat _ rightPats rhs mbBinds -> do 324 | maybe (return ()) tiBinds mbBinds 325 | ty <- expectAny exp_ty 326 | (patTys, retTy) <- unifyFuns (length $ leftPat:rightPats) ty 327 | forM_ (zip patTys (leftPat:rightPats)) $ \(patTy, pat) -> checkRho (tiPat pat) patTy 328 | checkRho (tiRhs rhs) retTy 329 | 330 | --matchPatterns :: Match l -> Int 331 | --matchPatterns (Match _ _ paths _ _) = length paths 332 | --matchPatterns InfixMatch{} = 2 333 | 334 | tiBinds :: Binds (Pin s) -> TI s () 335 | tiBinds binds = 336 | case binds of 337 | BDecls _ decls -> tiBindGroup decls 338 | _ -> error "Language.Haskell.TypeCheck.Infer.tiBinds" 339 | 340 | tiDecl :: Decl (Pin s) -> ExpectedRho s -> TI s () 341 | tiDecl decl exp_ty = 342 | case decl of 343 | FunBind _ matches -> do 344 | mapM_ (\match -> tiMatch match exp_ty) matches 345 | PatBind _ _pat rhs binds -> do 346 | maybe (return ()) tiBinds binds 347 | tiRhs rhs exp_ty 348 | ClassDecl{} -> return () 349 | _ -> unhandledSyntax "tiDecl" decl 350 | 351 | declIdent :: Decl (Pin s) -> SrcLoc 352 | declIdent decl = 353 | case decl of 354 | FunBind _ (Match _ name _ _ _:_) -> 355 | let Pin (Origin _ src) _ = ann name 356 | in getPointLoc src 357 | _ -> unhandledSyntax "declIdent" decl 358 | 359 | --tiImpls :: [Decl Origin] -> TI () 360 | --tiImpls impls = do 361 | -- forM_ impls $ \impl -> do 362 | -- ty <- TcMetaVar <$> newTcVar 363 | -- setAssumption (declIdent impl) ty 364 | -- tiDecl impl ty 365 | -- rTy <- zonk ty 366 | -- liftIO $ print rTy 367 | -- qualify the type sigs... 368 | 369 | declHeadType :: DeclHead (Pin s) -> ([TcVar], Entity, Pin s) 370 | declHeadType dhead = 371 | case dhead of 372 | DHead _ name -> 373 | let Pin (Origin (Binding gname) _) _ = ann name 374 | in ([], gname, ann name) 375 | DHApp _ dh tyVarBind -> 376 | let (tcVars, gname, pin) = declHeadType dh 377 | var = tcVarFromTyVarBind tyVarBind 378 | in (tcVars ++ [var], gname, pin) 379 | _ -> unhandledSyntax "declHeadType" dhead 380 | 381 | tcVarFromTyVarBind :: TyVarBind (Pin s) -> TcVar 382 | tcVarFromTyVarBind (KindedVar _ name _) = tcVarFromName name 383 | tcVarFromTyVarBind (UnkindedVar _ name) = tcVarFromName name 384 | 385 | instHeadType :: InstHead (Pin s) -> TI s ([TcType s], Entity) 386 | instHeadType ihead = 387 | case ihead of 388 | IHCon _ qname -> do 389 | gname <- qnameToEntity qname 390 | return ([], gname) 391 | IHInfix _ ty qname -> do 392 | ty' <- typeToTcType ty 393 | gname <- qnameToEntity qname 394 | return ([ty'], gname) 395 | IHParen _ ih -> instHeadType ih 396 | IHApp _ ih ty -> do 397 | ty' <- typeToTcType ty 398 | (tys, gname) <- instHeadType ih 399 | return (tys ++ [ty'], gname) 400 | 401 | tiConDecl :: [TcVar] -> TcType s -> ConDecl (Pin s) -> TI s (Pin s, [TcType s]) 402 | tiConDecl tvars dty conDecl = 403 | case conDecl of 404 | ConDecl _ con tys -> do 405 | tys' <- mapM typeToTcType tys 406 | return (ann con, tys') 407 | RecDecl _ con fields -> do 408 | conTys <- concat <$> sequence 409 | [ replicateM (length names) (typeToTcType ty) 410 | | FieldDecl _ names ty <- fields ] 411 | forM_ fields $ \(FieldDecl _ names fTy) -> do 412 | ty <- TcFun dty <$> typeToTcType fTy 413 | forM_ names $ \name -> do 414 | gname <- expectResolvedPin (ann name) 415 | setAssumption gname (TcForall tvars $ TcQual [] ty) 416 | return (ann con, conTys) 417 | _ -> unhandledSyntax "tiConDecl" conDecl 418 | 419 | tiQualConDecl :: [TcVar] -> TcType s -> QualConDecl (Pin s) -> 420 | TI s (Pin s, [TcType s]) 421 | tiQualConDecl tvars dty (QualConDecl _ _ _ con) = 422 | tiConDecl tvars dty con 423 | 424 | tiClassDecl :: Decl (Pin s) -> TI s () 425 | tiClassDecl decl = 426 | case decl of 427 | -- ClassDecl _ _ctx (DHead _ className [tyBind]) _deps (Just decls) -> 428 | -- sequence_ 429 | -- [ worker className tyBind name ty 430 | -- | ClsDecl _ (TypeSig _ names ty) <- decls, name <- names ] 431 | _ -> unhandledSyntax "tiClassDecl" decl 432 | where 433 | -- tcVarFromName :: Name Origin -> TcVar 434 | -- tcVarFromTyVarBind (KindedVar _ name _) = tcVarFromName name 435 | -- tcVarFromTyVarBind (UnkindedVar _ name) = tcVarFromName name 436 | -- worker className tyBind name ty = do 437 | -- -- name :: className tybind => ty 438 | -- let Origin (Resolved gname) _ = ann className 439 | -- Origin (Resolved (GlobalName src _qname)) _ = ann name 440 | -- tcVar = tcVarFromTyVarBind tyBind 441 | -- tcType = typeToTcType ty 442 | -- let scheme = TcForall [tcVar] ([IsIn gname (TcRef tcVar)] :=> tcType) 443 | -- setAssumption src scheme 444 | 445 | tiPrepareClassDecl :: Entity -> [TcVar] -> ClassDecl (Pin s) -> TI s () 446 | tiPrepareClassDecl className [tyVar] decl = 447 | case decl of 448 | ClsDecl _ (TypeSig _ names ty) -> do 449 | forM_ names $ \name -> do 450 | gname <- expectResolvedPin (ann name) 451 | ty' <- typeToTcType ty 452 | free <- getFreeTyVars [ty'] 453 | setAssumption gname 454 | (TcForall free ([TcIsIn className (TcRef tyVar)] `TcQual` ty')) 455 | setProof (ann name) id (TcForall free ([TcIsIn className (TcRef tyVar)] `TcQual` ty')) 456 | _ -> unhandledSyntax "tiPrepareClassDecl: " decl 457 | tiPrepareClassDecl _ _ decl = 458 | unhandledSyntax "tiPrepareClassDecl: " decl 459 | 460 | tiPrepareDecl :: Decl (Pin s) -> TI s () 461 | tiPrepareDecl decl = 462 | case decl of 463 | DataDecl _ _ _ dhead cons _ -> do 464 | let (tcvars, entity, pin) = declHeadType dhead 465 | qname = entityName entity 466 | dataTy = foldl TcApp (TcCon qname) (map TcRef tcvars) 467 | stars = map (const TcStar) tcvars 468 | setProof pin id (foldl TcFun TcStar stars) 469 | setAssumption entity (foldl TcFun TcStar stars) 470 | forM_ cons $ \qualCon -> do 471 | (pin, fieldTys) <- tiQualConDecl tcvars dataTy qualCon 472 | entity <- expectResolvedPin pin 473 | let ty = foldr TcFun dataTy fieldTys 474 | setProof pin (tcProofAbs tcvars) ty 475 | setAssumption entity (TcForall tcvars $ TcQual [] ty) 476 | FunBind{} -> return () 477 | PatBind{} -> return () 478 | TypeDecl{} -> return () 479 | InlineSig{} -> return () 480 | ForImp _ _conv _safety _mbExternal name ty -> do 481 | gname <- expectResolvedPin (ann name) 482 | setAssumption gname =<< typeToTcType ty 483 | TypeSig _ names ty -> 484 | forM_ names $ \name -> do 485 | gname <- expectResolvedPin (ann name) 486 | setAssumption gname =<< explicitTcForall =<< typeToTcType ty 487 | --setCoercion (nameIdentifier name) 488 | -- (CoerceAbs (freeTcVariables $ typeToTcType ty)) 489 | ClassDecl _ mbCtx dhead _funDeps mbDecls -> do 490 | let ([tcvar], className, _pin) = declHeadType dhead 491 | constraints <- tiMaybe [] contextToPredicates mbCtx 492 | let classDef = TcQual constraints (TcIsIn className (TcRef tcvar)) 493 | addClass classDef 494 | 495 | forM_ (fromMaybe [] mbDecls) $ \clsDecl -> 496 | tiPrepareClassDecl className [tcvar] clsDecl 497 | InstDecl _ _mbOverlap instRule _mbInstDecls -> do 498 | tiPrepareInstDecl instRule 499 | _ -> unhandledSyntax "tiPrepareDecl" decl 500 | 501 | tiPrepareInstDecl :: InstRule (Pin s) -> TI s () 502 | tiPrepareInstDecl (IParen _ instRule) = tiPrepareInstDecl instRule 503 | tiPrepareInstDecl (IRule _ _binds mbCtx instHead) = do 504 | constraints <- tiMaybe [] contextToPredicates mbCtx 505 | ([ty], className) <- instHeadType instHead 506 | let instDef = TcQual constraints (TcIsIn className ty) 507 | addInstance instDef 508 | 509 | -- instance Default Bool => 510 | -- Bool 511 | -- Default Bool 512 | -- Default 513 | -- instance Default (Maybe a) 514 | -- forall a. Maybe a 515 | -- forall a. Default (Maybe a) 516 | -- Default 517 | -- instance Show a => Default (Maybe a) 518 | -- forall a. Show a => Maybe a 519 | -- forall a. Show a => Default (Maybe a) 520 | -- Default 521 | instRuleType :: InstRule (Pin s) -> TI s (Sigma s, Sigma s, Entity) 522 | instRuleType (IParen _ instRule) = instRuleType instRule 523 | instRuleType (IRule _ mbBinds mbCtx instHead) = do 524 | let binds = maybe [] (map tcVarFromTyVarBind) mbBinds 525 | constraints <- tiMaybe [] contextToPredicates mbCtx 526 | ([ty], className) <- instHeadType instHead 527 | tyDef <- explicitTcForall $ TcForall binds (TcQual constraints ty) 528 | instDef <- explicitTcForall $ TcForall binds (TcQual constraints (TcCon (entityName className) `TcApp` ty)) 529 | return (tyDef,instDef,className) 530 | 531 | 532 | {- 533 | class Default a where 534 | def :: a 535 | instance Default Bool where 536 | def = True 537 | instance Default (Maybe b) where 538 | def = Nothing 539 | 540 | def :: Default a => a 541 | a = Maybe b 542 | 543 | class Weird a where 544 | weird :: Weird b => b -> a 545 | 546 | weird :: (Weird a, Weird b) => b -> a 547 | -} 548 | 549 | {- 550 | sigma = forall a b. Default a => b -> a 551 | tv = [sk_0_a] 552 | rho = Default sk_0_a => sk_0_a 553 | 554 | sigma -> tv -> sigma 555 | 556 | instance Show a => Default (Maybe a) 557 | 558 | def :: Default a => a 559 | def :: v0 560 | v0 = Maybe v1 561 | 562 | 563 | -} 564 | tiInstDecl :: Decl (Pin s) -> TI s () 565 | tiInstDecl (InstDecl _ _overlap instRule mbInstDecls) = do 566 | (instSigma, instDef, instClassName) <- instRuleType instRule 567 | -- debug $ "instSigma = " ++ show (Doc.pretty instSigma) 568 | setProof (ann instRule) id instDef 569 | 570 | (_, instPreds, tmpRho, _tmpToSigma) <- skolemize instSigma 571 | -- debug $ "tmpRho = " ++ show (Doc.pretty tmpRho) 572 | -- debug $ "instPreds = " ++ show (Doc.pretty instPreds) 573 | setPredicates instPreds 574 | 575 | (_clsPred, TcRef clsTv) <- lookupClass instClassName 576 | 577 | forM_ (fromMaybe [] mbInstDecls) $ \instDecl -> 578 | case instDecl of 579 | InsDecl _ decl -> do 580 | let [binder] = declBinders decl 581 | 582 | sigma <- findAssumption binder 583 | -- debug $ "sigma = " ++ show (Doc.pretty sigma) 584 | 585 | let sigma' = instantiateMethod sigma clsTv 586 | meta <- TcMetaVar <$> newTcVar 587 | sigma'' <- substituteTyVars [(clsTv, meta)] sigma' 588 | 589 | -- debug $ "sigma'' = " ++ show (Doc.pretty sigma'') 590 | 591 | unify meta tmpRho 592 | 593 | -- debug $ "sigma'' = " ++ show (Doc.pretty sigma'') 594 | 595 | (_tvs, preds, genRho, _prenexToSigma) <- skolemize sigma'' 596 | 597 | addPredicates preds 598 | 599 | -- debug $ "preds = " ++ show (Doc.pretty preds) 600 | -- debug $ "genRho = " ++ show (Doc.pretty genRho) 601 | 602 | -- predsAfter <- mapM lowerPredMetaVars =<< getPredicates 603 | 604 | -- debug $ "predsAfter = " ++ show (Doc.pretty predsAfter) 605 | 606 | checkRho (tiDecl decl) genRho 607 | afterPreds <- filterM (fmap not . entail (instPreds++preds)) =<< mapM lowerPredMetaVars =<< getPredicates 608 | 609 | -- debug $ "afterPreds = " ++ show (Doc.pretty afterPreds) 610 | 611 | rs <- simplifyAndDeferPredicates [] afterPreds 612 | 613 | -- debug $ "rs = " ++ show (Doc.pretty rs) 614 | 615 | unless (null rs) $ throwError ContextTooWeak 616 | 617 | ret <- explicitTcForall genRho 618 | 619 | setProof (ann decl) id ret 620 | _ -> unhandledSyntax "tiInstDecl" instDecl 621 | tiInstDecl _ = return () 622 | 623 | {- 624 | Story about predicates: 625 | Split type signature into a rho type and a list of starting predicates. 626 | Get list of predicates we got from type-checking. 627 | Remove predicates that are entailed by our starting predicates. 628 | Simplify predicates. 629 | Defer predicates that refer to outer meta variables. 630 | If any predicates are left using skolem variables: 631 | Context is too weak: Variable needed constraint which couldn't be found. 632 | Example: fn :: a -> String; fn x = show x 633 | If any predicates are left using meta variables: 634 | Example: fn x = show . read 635 | -} 636 | tiExpl :: (Decl (Pin s), Entity) -> TI s () 637 | tiExpl (decl, binder) = do 638 | -- debug $ "tiExpl: " ++ show (Doc.pretty binder) 639 | setPredicates [] 640 | sigma <- findAssumption binder 641 | 642 | (tvs, preds, rho, prenexToSigma) <- skolemize sigma 643 | -- debug $ "tiExpl: " ++ show (Doc.pretty binder) ++ " :: " ++ show (Doc.pretty sigma) 644 | -- debug $ "tiExpl: " ++ show (Doc.pretty binder) ++ " :: " ++ show (Doc.pretty rho) 645 | -- debug $ "tiExpl: " ++ "Before: " ++ show (Doc.pretty preds) 646 | checkRho (tiDecl decl) rho 647 | afterPreds <- filterM (fmap not . entail preds) =<< mapM lowerPredMetaVars =<< getPredicates 648 | -- debug $ "tiExpl: " ++ "After: " ++ show (Doc.pretty afterPreds) 649 | outer_meta <- getFreeMetaVariables 650 | rs <- simplifyAndDeferPredicates outer_meta afterPreds 651 | -- debug $ "tiExpl: " ++ "Kept: " ++ show (Doc.pretty rs) 652 | unless (null rs) $ throwError ContextTooWeak 653 | setProof (ann decl) (prenexToSigma) (TcForall tvs (TcQual preds rho)) 654 | mapM_ dropSkolem tvs 655 | -- setProof (ann decl) (prenexToSigma . tcProofAbs tvs) rho 656 | 657 | {- 658 | Predicates: 659 | collect predicates 660 | reduce/simplify predicates 661 | defer all predicates that refer to outer meta variables. 662 | default all predicates that don't refer to inner meta variables. 663 | quantify type signatures with predicates 664 | -} 665 | tiDecls :: [(Decl (Pin s), Entity)] -> TI s () 666 | tiDecls decls = withRecursive thisBindGroup $ do 667 | -- debug $ "Bind group: " ++ dshow False (map snd decls) 668 | outer_meta <- getFreeMetaVariables 669 | forM_ decls $ \(_decl, binder) -> do 670 | ty <- TcMetaVar <$> newTcVar 671 | setAssumption binder ty 672 | forM_ decls $ \(decl, binder) -> do 673 | ty <- findAssumption binder 674 | -- debug_ty <- resolveMetaVars ty 675 | -- debug $ dshow False binder ++ " :: " ++ show (Doc.pretty debug_ty) ++ " (start)" 676 | -- invariant: ty is Rho, not Sigma. 677 | checkRho (tiDecl decl) ty 678 | -- debug_ty <- resolveMetaVars ty 679 | -- debug $ dshow False binder ++ " :: " ++ show (Doc.pretty debug_ty) ++ " (end)" 680 | 681 | -- _preds <- getPredicates 682 | -- forM_ _preds $ debug . show . Doc.pretty 683 | 684 | knots <- getKnots 685 | outer_meta' <- getMetaTyVars $ map TcMetaVar outer_meta 686 | -- debug $ "Outer meta: " ++ show (Doc.pretty outer_meta') 687 | all_meta <- getFreeMetaVariables 688 | let new_meta = all_meta \\ outer_meta' 689 | 690 | let tvs = map toTcVar new_meta 691 | forM_ (zip new_meta tvs) $ \(var, ty) -> writeMetaVar var (TcRef ty) 692 | 693 | afterPreds <- mapM lowerPredMetaVars =<< getPredicates 694 | -- debug $ "tiDecls: " ++ "Outer: " ++ show (Doc.pretty outer_meta') 695 | -- debug $ "tiDecls: " ++ "After: " ++ show (Doc.pretty afterPreds) 696 | rs <- simplifyAndDeferPredicates outer_meta' =<< reduce afterPreds 697 | -- debug $ "tiDecls: " ++ "Keep: " ++ show (Doc.pretty rs) 698 | 699 | forM_ decls $ \(decl, binder) -> do 700 | ty <- findAssumption binder 701 | (gTy, tvs) <- quantify tvs rs ty 702 | -- debug_gTy <- resolveMetaVars gTy 703 | -- debug $ dshow False binder ++ " :: " ++ show (Doc.pretty debug_gTy) ++ " (knot)" 704 | -- setProof (ann decl) (flip tcProofAp (map TcRef tvs) . tcProofAbs tvs) gTy 705 | setProof (ann decl) id gTy 706 | -- proof <- getProof (ann decl) 707 | -- debug $ show $ Doc.pretty gTy 708 | setAssumption binder gTy 709 | 710 | forM_ knots $ \(thisBinder, usageLoc) -> 711 | when (binder == thisBinder) $ 712 | setProof usageLoc (`TcProofAp` map TcRef tvs) gTy 713 | 714 | when (null outer_meta') $ do 715 | renameProofs 716 | where 717 | thisBindGroup = map snd decls 718 | toTcVar (TcMetaRef name _) = TcUniqueVar name 719 | 720 | 721 | 722 | --error $ "tiDecls: " ++ show decls 723 | 724 | -- First go through the declarations and add explicit type signatures to 725 | -- the environment. Then type check the implicit declarations in their 726 | -- strongly connected groups. Lastly, verify the signature of explicitly 727 | -- typed declarations (this includes instance methods). 728 | tiBindGroup :: [Decl (Pin s)] -> TI s () 729 | tiBindGroup decls = do 730 | -- liftIO $ putStrLn $ "Explicit: " ++ show explicitlyTyped 731 | mapM_ tiPrepareDecl decls 732 | forM_ scc $ tiDecls . flattenSCC 733 | forM_ explicitDecls tiExpl 734 | mapM_ tiInstDecl decls 735 | where 736 | explicitlyTyped = 737 | [ nameIdentifier name 738 | | TypeSig _ names _ <- decls 739 | , name <- names ] 740 | -- [ nameIdentifier name 741 | -- | ClassDecl _ _ctx _head _funDep (Just clsDecls) <- decls 742 | -- , ClsDecl _ (TypeSig _ names _ty) <- clsDecls 743 | -- , name <- names ] 744 | explicitDecls = 745 | [ (decl, binder) 746 | | decl <- decls 747 | , binder <- declBinders decl 748 | , binder `elem` explicitlyTyped ] 749 | graph = 750 | [ ((decl, binder), binder, declFreeVariables decl ) 751 | | decl <- decls 752 | , binder <- declBinders decl 753 | , binder `notElem` explicitlyTyped ] 754 | scc = stronglyConnComp graph 755 | 756 | -- FIXME: Rename this function. We're not finding free variables, we finding 757 | -- all references. 758 | declFreeVariables :: Decl (Pin s) -> [Entity] 759 | declFreeVariables decl = 760 | case decl of 761 | FunBind _ matches -> concatMap freeMatch matches 762 | PatBind _ _pat rhs binds -> freeRhs rhs ++ freeBinds binds 763 | ClassDecl _ _ctx _head _funDep _mbDecls -> [] 764 | TypeSig{} -> [] 765 | _ -> unhandledSyntax "declFreeVariables" decl 766 | where 767 | -- freeClsDecl clsDecl = 768 | -- case clsDecl of 769 | -- ClsDecl _ decl -> 770 | -- case decl of 771 | -- TypeSig _ names _ty -> 772 | -- [ gname | Pin (Origin (Binding gname) _) _ <- map ann names ] 773 | -- _ -> unhandledSyntax "freeClsDecl" clsDecl 774 | freeBinds Nothing = [] 775 | freeBinds (Just (BDecls _src decls)) = concatMap declFreeVariables decls 776 | freeBinds _ = error "declFreeVariables, freeBinds" 777 | freeMatch match = 778 | case match of 779 | Match _ _ _pats rhs mbBinds -> freeRhs rhs ++ freeBinds mbBinds 780 | _ -> unhandledSyntax "freeMatch" match 781 | freeRhs rhs = 782 | case rhs of 783 | UnGuardedRhs _ expr -> freeExp expr 784 | _ -> unhandledSyntax "freeRhs" rhs 785 | freeExp expr = 786 | case expr of 787 | Var _ qname -> [qnameIdentifier qname] 788 | Con{} -> [] 789 | Lit{} -> [] 790 | Case _ scrut alts -> freeExp scrut ++ concatMap freeAlt alts 791 | App _ a b -> freeExp a ++ freeExp b 792 | InfixApp _ a op b -> freeExp a ++ freeQOp op ++ freeExp b 793 | Paren _ e -> freeExp e 794 | Lambda _ _pats e -> freeExp e 795 | Do _ stmts -> concatMap freeStmt stmts 796 | Tuple _ _ exprs -> concatMap freeExp exprs 797 | List _ exprs -> concatMap freeExp exprs 798 | Let _ binds e -> 799 | freeBinds (Just binds) ++ freeExp e 800 | _ -> unhandledSyntax "freeExp" expr 801 | freeStmt stmt = 802 | case stmt of 803 | Generator _ _pat expr -> freeExp expr 804 | Qualifier _ expr -> freeExp expr 805 | _ -> unhandledSyntax "freeStmt" stmt 806 | freeQOp op = 807 | case op of 808 | QVarOp _ qname -> [qnameIdentifier qname] 809 | QConOp{} -> [] 810 | freeAlt (Alt _ _pat rhs _binds) = freeRhs rhs 811 | 812 | qnameIdentifier :: QName (Pin s) -> Entity 813 | qnameIdentifier qname = 814 | case qname of 815 | Qual _ _ name -> nameIdentifier name 816 | UnQual _ name -> nameIdentifier name 817 | _ -> unhandledSyntax "qnameIdentifier" qname 818 | 819 | nameIdentifier :: Name (Pin s) -> Entity 820 | nameIdentifier name = 821 | case info of 822 | Resolved gname -> gname 823 | Binding gname -> gname 824 | _ -> unresolved "nameIdentifier" name 825 | where 826 | Pin (Origin info _) _ = ann name 827 | 828 | -- instance Default (Maybe a) where 829 | -- def = Nothing 830 | -- def :: Maybe a 831 | declBinders :: Decl (Pin s) -> [Entity] 832 | declBinders decl = 833 | case decl of 834 | DataDecl{} -> [] 835 | ForImp{} -> [] 836 | FunBind (Pin (Origin (Binding gname) _src) _) _matches -> [gname] 837 | PatBind _ pat _rhs _binds -> 838 | patBinders pat 839 | TypeDecl{} -> [] 840 | TypeSig{} -> [] 841 | ClassDecl{} -> [] 842 | InstDecl{} -> [] 843 | -- ClassDecl _ _ctx _head _funDep mbDecls -> 844 | -- maybe [] (concatMap classDeclBinders) mbDecls 845 | -- InstDecl _ _overlap _rule mbDecls -> 846 | -- maybe [] (concatMap instDeclBinders) mbDecls 847 | InlineSig{} -> [] 848 | _ -> unhandledSyntax "declBinders" decl 849 | 850 | instDeclBinders :: InstDecl (Pin s) -> [Entity] 851 | instDeclBinders instDecl = 852 | case instDecl of 853 | InsDecl _ decl -> declBinders decl 854 | _ -> unhandledSyntax "instDeclBinders" instDecl 855 | 856 | classDeclBinders :: ClassDecl (Pin s) -> [Entity] 857 | classDeclBinders clsDecl = 858 | case clsDecl of 859 | ClsDecl _ decl -> 860 | case decl of 861 | TypeSig _ names _ty -> map nameIdentifier names 862 | _ -> unhandledSyntax "classDeclBinders.decl" decl 863 | _ -> unhandledSyntax "classDeclBinders" clsDecl 864 | 865 | patBinders :: Pat (Pin s) -> [Entity] 866 | patBinders pat = 867 | case pat of 868 | PVar _ name -> [nameIdentifier name] 869 | _ -> unhandledSyntax "patBinders" pat 870 | 871 | tiModule :: Module (Pin s) -> TI s () 872 | tiModule m = 873 | case m of 874 | Module _ _dhead _pragma _imports decls -> 875 | tiBindGroup decls 876 | _ -> unhandledSyntax "tiModule" m 877 | 878 | 879 | 880 | 881 | unhandledSyntax :: HS.Pretty a => String -> a -> b 882 | unhandledSyntax tag ast = 883 | error $ "Language.Haskell.TypeCheck.SyntaxDirected." ++ tag ++ ":\n" ++ 884 | show (HS.prettyPrim ast) 885 | 886 | unresolved :: HS.Pretty a => String -> a -> b 887 | unresolved tag ast = error $ 888 | "Language.Haskell.TypeCheck.SyntaxDirected." ++ tag ++ 889 | ": Unresolved: " ++ show (HS.prettyPrim ast) 890 | -------------------------------------------------------------------------------- /src/Language/Haskell/TypeCheck/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | module Language.Haskell.TypeCheck.Types where 5 | 6 | import Control.Monad.ST 7 | import Control.Monad.ST.Unsafe 8 | import Data.Data 9 | import Data.STRef 10 | import GHC.Generics 11 | import Language.Haskell.Exts.SrcLoc 12 | import qualified Language.Haskell.TypeCheck.Pretty as P 13 | import System.IO.Unsafe 14 | import qualified Text.PrettyPrint.ANSI.Leijen as Doc 15 | 16 | import Language.Haskell.Scope (Entity (..), Location, 17 | QualifiedName (..)) 18 | import qualified Language.Haskell.Scope as Scope 19 | 20 | -- Type variables are uniquely identified by their name and binding point. 21 | data TcVar 22 | = TcVar String Location 23 | | TcSkolemVar String 24 | | TcUniqueVar Int 25 | deriving ( Show, Eq, Ord, Data, Generic ) 26 | 27 | -- data TcVar_ = TcVar String Location | SkolemVar String | UniqueVar Int 28 | 29 | data TyVar = TyVar String 30 | deriving ( Show, Eq, Ord, Data, Generic ) 31 | 32 | data TcMetaVar s = TcMetaRef Int (STRef s (Maybe (TcType s))) 33 | instance Show (TcMetaVar s) where 34 | show (TcMetaRef name _) = show name 35 | instance Eq (TcMetaVar s) where 36 | TcMetaRef _ r1 == TcMetaRef _ r2 = r1==r2 37 | instance Ord (TcMetaVar s) where 38 | compare (TcMetaRef i1 _) (TcMetaRef i2 _) = compare i1 i2 39 | 40 | data Expected s a = Infer (STRef s a) | Check a 41 | 42 | data TcType s 43 | = TcForall [TcVar] (TcQual s (TcType s)) 44 | | TcFun (TcType s) (TcType s) 45 | | TcApp (TcType s) (TcType s) 46 | -- Uninstantiated tyvar 47 | | TcRef TcVar 48 | | TcCon QualifiedName 49 | -- Instantiated tyvar 50 | | TcMetaVar (TcMetaVar s) 51 | | TcUnboxedTuple [TcType s] 52 | | TcTuple [TcType s] 53 | | TcList (TcType s) 54 | | TcStar 55 | -- | TcUndefined 56 | deriving ( Show, Eq, Ord ) 57 | 58 | -- Foralls can appear anywhere. 59 | type Sigma s = TcType s 60 | -- No foralls at the top-level 61 | type Rho s = TcType s 62 | -- No foralls anywhere. 63 | type Tau s = TcType s 64 | 65 | type ExpectedRho s = Expected s (Rho s) 66 | 67 | -- data TyVar = TyVar String Location 68 | -- deriving ( Show, Eq, Ord ) 69 | 70 | data Type 71 | = TyForall [TyVar] (Qualified Type) 72 | | TyFun Type Type 73 | | TyApp Type Type 74 | | TyRef TyVar 75 | | TyCon QualifiedName 76 | | TyUnboxedTuple [Type] 77 | | TyTuple [Type] 78 | | TyList Type 79 | | TyStar 80 | -- | TyUndefined 81 | deriving ( Show, Eq, Ord, Data, Generic ) 82 | 83 | toTcType :: Type -> TcType s 84 | toTcType ty = 85 | case ty of 86 | TyForall tyvars (predicates :=> t) -> 87 | TcForall [ TcVar name [] | TyVar name <- tyvars ] (TcQual (map toTcPred predicates) (toTcType t)) 88 | TyFun t1 t2 -> TcFun (toTcType t1) (toTcType t2) 89 | TyApp t1 t2 -> TcApp (toTcType t1) (toTcType t2) 90 | TyRef (TyVar name) -> TcRef (TcVar name []) 91 | TyCon qualifiedName -> TcCon qualifiedName 92 | TyUnboxedTuple tys -> TcUnboxedTuple (map toTcType tys) 93 | TyTuple tys -> TcTuple (map toTcType tys) 94 | TyList t1 -> TcList (toTcType t1) 95 | -- TyUndefined -> TcUndefined 96 | TyStar -> TcStar 97 | 98 | toTcPred :: Predicate -> TcPred s 99 | toTcPred (IsIn className ty) = TcIsIn className (toTcType ty) 100 | 101 | type TcCoercion s = TcProof s -> TcProof s 102 | data TcProof s 103 | = TcProofAbs [TcVar] (TcProof s) 104 | | TcProofAp (TcProof s) [TcType s] 105 | | TcProofLam Int (TcType s) (TcProof s) 106 | | TcProofSrc (TcType s) 107 | | TcProofPAp (TcProof s) (TcProof s) 108 | | TcProofVar Int 109 | deriving (Show) 110 | 111 | data Proof 112 | = ProofAbs [TyVar] Proof 113 | | ProofAp Proof [Type] 114 | | ProofLam Int Type Proof 115 | | ProofSrc Type 116 | | ProofPAp Proof Proof 117 | | ProofVar Int 118 | deriving (Eq, Ord, Show, Data, Generic) 119 | 120 | 121 | 122 | -- for arguments to the left of -> 123 | arrowPrecedence :: Int 124 | arrowPrecedence = 1 125 | 126 | -- for arguments of type or data constructors, or of a class. 127 | appPrecedence :: Int 128 | appPrecedence = 2 129 | 130 | instance P.Pretty (TcType s) where 131 | prettyPrec p thisTy = 132 | case thisTy of 133 | TcForall [] (TcQual [] t) -> 134 | P.prettyPrec p t 135 | TcForall vars qual -> P.parensIf (p > 0) $ 136 | Doc.text "∀" Doc.<+> Doc.hsep (map P.pretty vars) Doc.<> 137 | Doc.dot Doc.<+> P.pretty qual 138 | TcFun a b -> P.parensIf (p > 0) $ 139 | P.prettyPrec arrowPrecedence a Doc.<+> 140 | Doc.text "→ " Doc.<+> P.pretty b 141 | TcApp a b -> P.parensIf (p > arrowPrecedence) $ 142 | P.pretty a Doc.<+> P.prettyPrec appPrecedence b 143 | TcCon (QualifiedName "" ident) -> 144 | Doc.text ident 145 | TcCon (QualifiedName m ident) -> 146 | Doc.text (m ++ "." ++ ident) 147 | TcRef var -> P.pretty var 148 | TcMetaVar meta -> 149 | P.prettyPrec p meta 150 | TcUnboxedTuple tys -> 151 | Doc.text "(#" Doc.<+> 152 | Doc.hsep (Doc.punctuate Doc.comma $ map P.pretty tys) Doc.<+> 153 | Doc.text "#)" 154 | TcTuple tys -> Doc.tupled (map P.pretty tys) 155 | TcList ty -> 156 | Doc.brackets (P.pretty ty) 157 | -- TcUndefined -> 158 | -- Doc.red (Doc.text "undefined") 159 | TcStar -> 160 | Doc.text "*" 161 | 162 | instance P.Pretty TcVar where 163 | pretty (TcVar ident _src) = Doc.text ident 164 | pretty (TcSkolemVar ident) = Doc.text "skolem" <> Doc.parens (Doc.text ident) 165 | pretty (TcUniqueVar ident) = Doc.int ident 166 | 167 | instance P.Pretty TyVar where 168 | pretty (TyVar ident) = Doc.text ident 169 | 170 | unsafePerformST :: ST s a -> a 171 | unsafePerformST = unsafePerformIO . unsafeSTToIO 172 | 173 | instance P.Pretty (TcMetaVar s) where 174 | prettyPrec p (TcMetaRef ident ref) = 175 | -- Doc.parens (Doc.text ident) Doc.<> 176 | unsafePerformST (do 177 | mbTy <- readSTRef ref 178 | case mbTy of 179 | Just ty -> return $ Doc.blue (Doc.int ident) Doc.<> Doc.angles (P.prettyPrec p ty) 180 | Nothing -> return $ Doc.red (Doc.int ident)) 181 | -- pretty (TcMetaRef ident _) = Doc.red (Doc.text ident) 182 | 183 | instance P.Pretty t => P.Pretty (TcQual s t) where 184 | prettyPrec p (TcQual [] t) = P.prettyPrec p t 185 | prettyPrec p (TcQual quals t) = 186 | P.parensIf (length quals > 1) (Doc.hsep $ Doc.punctuate Doc.comma $ map P.pretty quals) Doc.<+> 187 | Doc.text "⇒" Doc.<+> P.prettyPrec p t 188 | 189 | instance P.Pretty t => P.Pretty (Qualified t) where 190 | prettyPrec p ([] :=> t) = P.prettyPrec p t 191 | prettyPrec p (quals :=> t) = 192 | P.parensIf (length quals > 1) (Doc.hsep $ Doc.punctuate Doc.comma $ map P.pretty quals) Doc.<+> 193 | Doc.text "⇒" Doc.<+> P.prettyPrec p t 194 | 195 | instance P.Pretty Entity where 196 | pretty = P.pretty . entityName 197 | 198 | instance P.Pretty QualifiedName where 199 | pretty (QualifiedName m ident) = 200 | Doc.text (m ++ "." ++ ident) 201 | 202 | instance P.Pretty (TcPred s) where 203 | pretty (TcIsIn gname t) = 204 | P.pretty gname Doc.<+> P.pretty t 205 | 206 | instance P.Pretty Predicate where 207 | pretty (IsIn gname t) = 208 | P.pretty gname Doc.<+> P.pretty t 209 | 210 | 211 | instance P.Pretty Type where 212 | prettyPrec p thisTy = 213 | case thisTy of 214 | -- TyForall [] ([] :=> t) -> 215 | -- P.prettyPrec p t 216 | TyForall vars qual -> P.parensIf (p > 0) $ 217 | Doc.text "∀" Doc.<+> Doc.hsep (map P.pretty vars) Doc.<> 218 | Doc.dot Doc.<+> P.pretty qual 219 | TyFun a b -> P.parensIf (p > 0) $ 220 | P.prettyPrec arrowPrecedence a Doc.<+> 221 | Doc.text "→ " Doc.<+> P.pretty b 222 | TyApp a b -> P.parensIf (p > arrowPrecedence) $ 223 | P.pretty a Doc.<+> P.prettyPrec appPrecedence b 224 | TyCon (QualifiedName "" ident) -> 225 | Doc.text ident 226 | TyCon (QualifiedName m ident) -> 227 | Doc.text (m ++ "." ++ ident) 228 | TyRef var -> P.pretty var 229 | TyUnboxedTuple tys -> 230 | Doc.text "(#" Doc.<+> 231 | Doc.hsep (Doc.punctuate Doc.comma $ map P.pretty tys) Doc.<+> 232 | Doc.text "#)" 233 | TyTuple tys -> Doc.tupled (map P.pretty tys) 234 | TyList ty -> 235 | Doc.brackets (P.pretty ty) 236 | TyStar -> Doc.text "*" 237 | -- TyUndefined -> 238 | -- Doc.red (Doc.text "undefined") 239 | 240 | instance P.Pretty Proof where 241 | prettyPrec prec p = 242 | case p of 243 | ProofAbs tvs p' -> P.parensIf (prec > 0) $ 244 | Doc.text "Λ" Doc.<> Doc.hsep (map P.pretty tvs) Doc.<> Doc.dot Doc.<+> P.pretty p' 245 | ProofAp p' tys -> P.parensIf (prec > 0) $ 246 | P.prettyPrec arrowPrecedence p' Doc.<+> Doc.text "@" Doc.<+> Doc.hsep (map (P.prettyPrec appPrecedence) tys) 247 | ProofLam n ty p' -> -- P.parensIf (True) $ 248 | Doc.text "λ" Doc.<> 249 | Doc.int n Doc.<> Doc.text "::" Doc.<> P.prettyPrec appPrecedence ty Doc.<> 250 | Doc.dot Doc.<+> P.pretty p' 251 | ProofSrc ty -> P.prettyPrec prec ty 252 | ProofPAp p1 p2 -> P.parensIf (prec > arrowPrecedence) $ 253 | P.prettyPrec arrowPrecedence p1 Doc.<+> P.prettyPrec appPrecedence p2 254 | ProofVar n -> Doc.int n 255 | 256 | instance P.Pretty (TcProof s) where 257 | prettyPrec prec p = 258 | case p of 259 | TcProofAbs tvs p' -> P.parensIf (prec > 0) $ 260 | Doc.text "Λ" Doc.<> Doc.hsep (map P.pretty tvs) Doc.<> Doc.dot Doc.<+> P.pretty p' 261 | TcProofAp p' tys -> P.parensIf (prec > 0) $ 262 | P.prettyPrec arrowPrecedence p' Doc.<+> Doc.text "@" Doc.<+> Doc.hsep (map (P.prettyPrec appPrecedence) tys) 263 | TcProofLam n ty p' -> -- P.parensIf (True) $ 264 | Doc.text "λ" Doc.<> 265 | Doc.int n Doc.<> Doc.text "::" Doc.<> P.prettyPrec appPrecedence ty Doc.<> 266 | Doc.dot Doc.<+> P.pretty p' 267 | TcProofSrc ty -> P.prettyPrec prec ty 268 | TcProofPAp p1 p2 -> P.parensIf (prec > arrowPrecedence) $ 269 | P.prettyPrec arrowPrecedence p1 Doc.<+> P.prettyPrec appPrecedence p2 270 | TcProofVar n -> Doc.int n 271 | 272 | data TcQual s t = TcQual [TcPred s] t 273 | deriving ( Show, Eq, Ord ) 274 | data Qualified t = [Predicate] :=> t 275 | deriving ( Show, Eq, Ord, Data, Generic ) 276 | 277 | data TcPred s = TcIsIn Entity (TcType s) 278 | deriving ( Show, Eq, Ord ) 279 | data Predicate = IsIn Entity Type 280 | deriving ( Show, Eq, Ord, Data, Generic ) 281 | 282 | -- type TcInstance s = TcQual s (TcPred s) 283 | -- type Instance = Qualified Predicate 284 | 285 | --data Typed = Typed TcType Origin 286 | 287 | data Typed 288 | = Coerced Scope.NameInfo SrcSpanInfo Proof 289 | | Scoped Scope.NameInfo SrcSpanInfo 290 | deriving (Show) 291 | 292 | data Pin s = Pin Scope.Origin (STRef s (Maybe (TcProof s))) 293 | 294 | instance Show (Pin s) where 295 | show (Pin origin _ref) = show origin 296 | -------------------------------------------------------------------------------- /src/Language/Haskell/TypeCheck/Unify.hs: -------------------------------------------------------------------------------- 1 | module Language.Haskell.TypeCheck.Unify where 2 | 3 | import Language.Haskell.TypeCheck.Types 4 | import Language.Haskell.TypeCheck.Monad 5 | import Language.Haskell.TypeCheck.Misc 6 | 7 | import Control.Monad 8 | import Control.Monad.Except 9 | import Data.STRef 10 | 11 | import qualified Language.Haskell.TypeCheck.Pretty as P 12 | 13 | unifyExpected :: Tau s -> ExpectedRho s -> TI s () 14 | unifyExpected tau exp_ty = 15 | case exp_ty of 16 | Check rho -> unify tau rho 17 | Infer ref -> liftST $ writeSTRef ref tau 18 | 19 | unify :: Tau s -> Tau s -> TI s () 20 | -- unify a b | trace ("Unify: " ++ show (P.pretty a) ++ " = " ++ show (P.pretty b)) False = undefined 21 | unify (TcList a) (TcList b) = 22 | unify a b 23 | unify (TcTuple as) (TcTuple bs) | length as == length bs = 24 | zipWithM_ unify as bs 25 | unify (TcApp la lb) (TcApp ra rb) = do 26 | unify la ra 27 | unify lb rb 28 | unify (TcFun la lb) (TcFun ra rb) = do 29 | unify la ra 30 | unify lb rb 31 | unify (TcCon left) (TcCon right) 32 | | left == right = return () 33 | | otherwise = throwError $ UnificationError $ "unify con: " ++ show (left,right) 34 | unify (TcUnboxedTuple as) (TcUnboxedTuple bs) 35 | | length as == length bs = zipWithM_ unify as bs 36 | unify (TcMetaVar ref) a = unifyMetaVar ref a 37 | unify a (TcMetaVar ref) = unifyMetaVar ref a 38 | unify (TcRef a) (TcRef b) | a == b = return () 39 | unify (TcRef a) _ = throwError $ UnificationError $ "Unexpected ref: " ++ show (P.pretty a) 40 | unify a b = throwError $ UnificationError $ show (P.pretty a) ++ " <=> " ++ show (P.pretty b) 41 | 42 | unifyMetaVar :: TcMetaVar s -> TcType s -> TI s () 43 | unifyMetaVar a (TcMetaVar b) | a == b = return () 44 | unifyMetaVar a@(TcMetaRef _ident ref) rightTy = do 45 | mbSubst <- liftST $ readSTRef ref 46 | case mbSubst of 47 | Just leftTy -> unify leftTy rightTy 48 | Nothing -> unifyUnboundVar a rightTy 49 | 50 | unifyUnboundVar :: TcMetaVar s -> TcType s -> TI s () 51 | unifyUnboundVar tv (TcMetaVar b@(TcMetaRef _ refB)) = do 52 | mbSubst <- liftST $ readSTRef refB 53 | case mbSubst of 54 | Just ty -> unify (TcMetaVar tv) ty 55 | Nothing -> writeMetaVar tv (TcMetaVar b) 56 | unifyUnboundVar tv b = do 57 | tvs <- getMetaTyVars [b] 58 | if tv `elem` tvs 59 | then throwError $ UnificationError "occurs check failed" 60 | else writeMetaVar tv b 61 | 62 | unifyFun :: Rho s -> TI s (Sigma s, Rho s) 63 | unifyFun (TcFun a b) = return (a,b) 64 | unifyFun ty = do 65 | a <- TcMetaVar <$> newTcVar 66 | b <- TcMetaVar <$> newTcVar 67 | unify ty (TcFun a b) 68 | return (a, b) 69 | 70 | unifyFun2 :: Rho s -> TI s (Sigma s, Sigma s, Rho s) 71 | unifyFun2 rho = do 72 | (a_ty, tmp) <- unifyFun rho 73 | (b_ty, ret) <- unifyFun tmp 74 | return (a_ty, b_ty, ret) 75 | 76 | unifyFuns :: Int -> Rho s -> TI s ([Sigma s], Rho s) 77 | unifyFuns = worker [] 78 | where 79 | worker acc 0 ty = return (reverse acc, ty) 80 | worker acc n (TcFun a b) = worker (a : acc) (n-1) b 81 | worker acc n ty = do 82 | args <- replicateM n $ TcMetaVar <$> newTcVar 83 | ret <- TcMetaVar <$> newTcVar 84 | unify ty (foldr TcFun ret args) 85 | return (reverse acc ++ args, ret) 86 | 87 | unifyApp :: Rho s -> TI s (Sigma s, Sigma s) 88 | unifyApp (TcApp a b) = pure (a,b) 89 | unifyApp ty = do 90 | a <- TcMetaVar <$> newTcVar 91 | b <- TcMetaVar <$> newTcVar 92 | unify ty (TcApp a b) 93 | return (a, b) 94 | 95 | unifyUnboxedTuple :: Int -> Rho s -> TI s [Sigma s] 96 | unifyUnboxedTuple n (TcUnboxedTuple tys) | length tys == n = return tys 97 | unifyUnboxedTuple n ty = do 98 | tys <- replicateM n $ TcMetaVar <$> newTcVar 99 | unify ty (TcUnboxedTuple tys) 100 | return tys 101 | 102 | unifyTuple :: Int -> Rho s -> TI s [Sigma s] 103 | unifyTuple n (TcTuple tys) | length tys == n = return tys 104 | unifyTuple n ty = do 105 | tys <- replicateM n $ TcMetaVar <$> newTcVar 106 | unify ty (TcTuple tys) 107 | return tys 108 | 109 | unifyList :: Rho s -> TI s (Sigma s) 110 | unifyList (TcList elt) = return elt 111 | unifyList ty = do 112 | elt <- TcMetaVar <$> newTcVar 113 | unify ty (TcList elt) 114 | return elt 115 | 116 | 117 | 118 | 119 | 120 | 121 | -- matchTypes (TcIsIn "Ord" value) (TcIsIn "Ord" a) = Just [(a, value)] 122 | -- matchTypes (TcIsIn "Ord" value) (TcIsIn "blah" a) = Nothing 123 | -- matchTypes (TcIsIn "Ord" value) (TcIsIn "Ord" (a,b)) = Nothing 124 | -- matchTypes (TcIsIn "Ord" (Int, t1)) (TcIsIn "Ord" (a,b)) = Just [(a, Int), (b, t1)] 125 | -- matchTypes (TcIsIn "Ord" ref) (TcIsIn "Ord" a) = Just [(a, ref)] 126 | matchTypes :: TcType s -> TcType s -> TI s (Maybe [(TcVar, TcType s)]) 127 | matchTypes t1 t2 = flip catchError (const $ return Nothing) $ do 128 | tvs <- getFreeTyVars [t2] 129 | tvs' <- replicateM (length tvs) newTcVar 130 | t2' <- substituteTyVars (zip tvs $ map TcMetaVar tvs') t2 131 | 132 | mtvs <- getMetaTyVars [t1] 133 | mtvs' <- replicateM (length mtvs) $ do 134 | u <- newUnique 135 | return $ TcVar ("tmp_" ++ show u) ["internal"] 136 | t1' <- substituteMetaVars (zip mtvs $ map TcRef mtvs') t1 137 | -- debug $ show $ P.pretty t1' 138 | -- debug $ show $ P.pretty t2' 139 | unify t1' t2' 140 | -- debug $ "Unification OK" 141 | tys <- forM tvs' $ \(TcMetaRef _ ref) -> do 142 | mbTy <- liftST (readSTRef ref) 143 | case mbTy of 144 | Nothing -> throwError MatchError 145 | Just (TcRef tv) 146 | | Just meta <- lookup tv (zip mtvs' mtvs) 147 | -> return $ TcMetaVar meta 148 | Just ty -> return ty 149 | return $ Just (zip tvs tys) 150 | 151 | -- bySuper (TcIsIn "Ord" tcref) = [TcIsIn "Ord" tcref, TcIsIn "Eq" tcref] 152 | bySuper :: TcPred s -> TI s [TcPred s] 153 | bySuper p@(TcIsIn className ty) = do 154 | -- Constraints are the superclasses to our class. 155 | (constraints, classTy) <- lookupClass className 156 | -- Hmm, 'classTy' should always just be a TcRef so matching shouldn't be 157 | -- able to fail. 158 | mbSubst <- matchTypes ty classTy 159 | case mbSubst of 160 | Nothing -> return [p] 161 | Just subst -> do 162 | ps <- mapM (substituteTyVarsPred subst) constraints 163 | return (p:ps) 164 | 165 | -- byInst (TcIsIn "Ord" (a, b)) = Just [TcIsIn "Ord" a, TcIsIn "Ord" b] 166 | -- byInst (TcIsIn "Ord" (a -> b)) = Nothing 167 | byInst :: TcPred s -> TI s (Maybe [TcPred s]) 168 | byInst (TcIsIn className ty) = do 169 | insts <- lookupInstances className 170 | go insts 171 | where 172 | go [] = return Nothing 173 | go ((constraints, instTy):rest) = do 174 | -- debug $ "Ty: " ++ show (P.pretty ty) 175 | -- debug $ "Inst: " ++ show (P.pretty instTy) 176 | mbSubst <- matchTypes ty instTy 177 | case mbSubst of 178 | Nothing -> go rest 179 | Just subst -> 180 | Just <$> mapM (substituteTyVarsPred subst) constraints 181 | 182 | -- True iff p is given by ps. 183 | -- Superclasses: 184 | -- class Eq a => Ord a 185 | -- Instances: 186 | -- instance Show a => Show [a] 187 | -- 188 | -- entail [TcIsIn "Ord" a] (TcIsIn "Eq" a) = True 189 | -- entail [] (TcIsIn "Ord" (Int, Char)) = True 190 | -- entail [TcIsIn "Ord" a] (TcIsIn "Eq" (Int, a)) = True 191 | -- byInst: [TcIsIn "Eq" Int, TcIsIn "Eq" a] 192 | -- entail [TcIsIn "MArray" a e m] (TcIsIn "Monad" m) 193 | -- bySuper: TcIsIn "MArray" a e m => [TcIsIn "Monad" m] 194 | entail :: [TcPred s] -> TcPred s -> TI s Bool 195 | entail ps p = do 196 | superSet <- mapM bySuper ps 197 | if any (p `elem`) superSet 198 | then return True 199 | else do 200 | mbInst <- byInst p 201 | case mbInst of 202 | Nothing -> return False 203 | Just constraints -> and <$> mapM (entail ps) constraints 204 | 205 | inHnf :: TcPred s -> Bool 206 | inHnf (TcIsIn _c t) = hnf t 207 | where 208 | hnf TcRef{} = True 209 | hnf (TcApp t _) = hnf t 210 | hnf TcMetaVar{} = True 211 | hnf _ = False 212 | 213 | -- toHnf (TcIsIn "Eq" (a,b)) = [TcIsIn "Eq" a, TcIsIn "Eq" b] 214 | toHnf :: TcPred s -> TI s [TcPred s] 215 | toHnf p 216 | | inHnf p = return [p] 217 | | otherwise = do 218 | mbInst <- byInst p 219 | case mbInst of 220 | Nothing -> throwError $ GeneralError $ "context reduction: " ++ show (P.pretty p) 221 | Just ps -> concat <$> mapM toHnf ps 222 | 223 | simplify :: [TcPred s] -> TI s [TcPred s] 224 | simplify = loop [] 225 | where 226 | loop rs [] = pure rs 227 | loop rs (p:ps) = do 228 | doesEntail <- entail (rs++ps) p 229 | if doesEntail 230 | then loop rs ps 231 | else loop (p:rs) ps 232 | 233 | reduce :: [TcPred s] -> TI s [TcPred s] 234 | reduce ps = simplify =<< concat <$> mapM toHnf ps 235 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.26 2 | 3 | allow-newer: false 4 | 5 | packages: 6 | - '.' 7 | 8 | - location: 9 | git: https://github.com/haskell-suite/haskell-scope.git 10 | commit: 6a149be78c62248ca4b76fc5279b55c01d548010 11 | extra-dep: true 12 | 13 | extra-deps: 14 | - haskell-src-exts-1.21.0 15 | -------------------------------------------------------------------------------- /tests/AbsAp1.hs: -------------------------------------------------------------------------------- 1 | module AbsAp1 where 2 | 3 | data Maybe a = Just a | Nothing 4 | 5 | id x = x 6 | 7 | fromJust :: Maybe a -> a 8 | fromJust mb = 9 | case mb of 10 | Just a -> id a 11 | 12 | 13 | -------------------------------------------------------------------------------- /tests/AbsAp1.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: * → * 3 | data Maybe a = Just a | Nothing 4 | :: Λa. a → AbsAp1.Maybe a 5 | data Maybe a = Just a | Nothing 6 | :: Λa. AbsAp1.Maybe a 7 | data Maybe a = Just a | Nothing 8 | :: ∀ a. a → a 9 | id x = x 10 | :: a 11 | id x = x 12 | :: ∀ a. AbsAp1.Maybe a → a 13 | fromJust mb = 14 |  case mb of 15 |  Just a -> id a 16 | :: AbsAp1.Maybe a 17 | fromJust mb = 18 | :: a 19 | Just a -> id a 20 | 21 | Proofs: 22 | coercion: (∀ a. a → AbsAp1.Maybe a) @ a 23 | Just a -> id a 24 | coercion: a 25 | id x = x 26 | coercion: AbsAp1.Maybe a 27 | case mb of 28 | coercion: (∀ a. a → a) @ a 29 | Just a -> id a 30 | coercion: a 31 | Just a -> id a 32 | -------------------------------------------------------------------------------- /tests/AbsAp2.hs: -------------------------------------------------------------------------------- 1 | module AbsAp2 where 2 | 3 | undefined x = undefined x 4 | 5 | test a = undefined a 6 | -------------------------------------------------------------------------------- /tests/AbsAp2.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: ∀ a b. a → b 3 | undefined x = undefined x 4 | :: a 5 | undefined x = undefined x 6 | :: ∀ a b. a → b 7 | test a = undefined a 8 | :: a 9 | test a = undefined a 10 | 11 | Proofs: 12 | coercion: (∀ a b. a → b) @ a b 13 | undefined x = undefined x 14 | coercion: a 15 | undefined x = undefined x 16 | coercion: (∀ a b. a → b) @ a b 17 | test a = undefined a 18 | coercion: a 19 | test a = undefined a 20 | -------------------------------------------------------------------------------- /tests/AbsAp3.hs: -------------------------------------------------------------------------------- 1 | module AbsAp3 where 2 | 3 | fn1 x = fn2 x 4 | 5 | fn2 y = () 6 | where 7 | fn3 a z = fn1 z 8 | -------------------------------------------------------------------------------- /tests/AbsAp3.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: ∀ a. a → () 3 | fn1 x = fn2 x 4 | :: a 5 | fn1 x = fn2 x 6 | :: ∀ a. a → () 7 | fn2 y = () 8 |  where 9 |  fn3 a z = fn1 z 10 | :: a 11 | fn2 y = () 12 | :: ∀ b. b → a → () 13 | fn3 a z = fn1 z 14 | :: b 15 | fn3 a z = fn1 z 16 | :: a 17 | fn3 a z = fn1 z 18 | 19 | Proofs: 20 | coercion: (∀ a. a → ()) @ a 21 | fn1 x = fn2 x 22 | coercion: a 23 | fn1 x = fn2 x 24 | coercion: (∀ a. a → ()) @ a 25 | fn3 a z = fn1 z 26 | coercion: a 27 | fn3 a z = fn1 z 28 | -------------------------------------------------------------------------------- /tests/AbsAp4.hs: -------------------------------------------------------------------------------- 1 | module AbsAp4 where 2 | 3 | undefined x = undefined x 4 | 5 | fn1 x = fn2 x undefined 6 | 7 | fn2 y i = () 8 | where 9 | fn3 a z = fn1 z 10 | -------------------------------------------------------------------------------- /tests/AbsAp4.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: ∀ a b. a → b 3 | undefined x = undefined x 4 | :: a 5 | undefined x = undefined x 6 | :: ∀ c. c → () 7 | fn1 x = fn2 x undefined 8 | :: c 9 | fn1 x = fn2 x undefined 10 | :: ∀ a b c. c → (a → b) → () 11 | fn2 y i = () 12 |  where 13 |  fn3 a z = fn1 z 14 | :: c 15 | fn2 y i = () 16 | :: a → b 17 | fn2 y i = () 18 | :: ∀ d. d → c → () 19 | fn3 a z = fn1 z 20 | :: d 21 | fn3 a z = fn1 z 22 | :: c 23 | fn3 a z = fn1 z 24 | 25 | Proofs: 26 | coercion: (∀ a b. a → b) @ a b 27 | undefined x = undefined x 28 | coercion: a 29 | undefined x = undefined x 30 | coercion: (∀ a b c. c → (a → b) → ()) @ a b c 31 | fn1 x = fn2 x undefined 32 | coercion: c 33 | fn1 x = fn2 x undefined 34 | coercion: (∀ a b. a → b) @ a b 35 | fn1 x = fn2 x undefined 36 | coercion: (∀ c. c → ()) @ c 37 | fn3 a z = fn1 z 38 | coercion: c 39 | fn3 a z = fn1 z 40 | -------------------------------------------------------------------------------- /tests/Append.hs: -------------------------------------------------------------------------------- 1 | module Append where 2 | 3 | data List a = Nil | Cons a (List a) 4 | 5 | append :: List x -> List x -> List x 6 | append a b = 7 | case a of 8 | Nil -> b 9 | Cons x xs -> Cons x (append xs b) 10 | -------------------------------------------------------------------------------- /tests/Append.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: * → * 3 | data List a = Nil | Cons a (List a) 4 | :: Λa. Append.List a 5 | data List a = Nil | Cons a (List a) 6 | :: Λa. a → Append.List a → Append.List a 7 | data List a = Nil | Cons a (List a) 8 | :: ∀ x. Append.List x → Append.List x → Append.List x 9 | append a b = 10 |  case a of 11 |  Nil -> b 12 |  Cons x xs -> Cons x (append xs b) 13 | :: Append.List x 14 | append a b = 15 | :: Append.List x 16 | append a b = 17 | :: x 18 | Cons x xs -> Cons x (append xs b) 19 | :: Append.List x 20 | Cons x xs -> Cons x (append xs b) 21 | 22 | Proofs: 23 | coercion: (∀ a. Append.List a) @ x 24 | Nil -> b 25 | coercion: (∀ a. a → Append.List a → Append.List a) @ x 26 | Cons x xs -> Cons x (append xs b) 27 | coercion: Append.List x 28 | case a of 29 | coercion: Append.List x 30 | Nil -> b 31 | coercion: (∀ a. a → Append.List a → Append.List a) @ x 32 | Cons x xs -> Cons x (append xs b) 33 | coercion: x 34 | Cons x xs -> Cons x (append xs b) 35 | coercion: (∀ x. Append.List x → Append.List x → Append.List x) @ x 36 | Cons x xs -> Cons x (append xs b) 37 | coercion: Append.List x 38 | Cons x xs -> Cons x (append xs b) 39 | coercion: Append.List x 40 | Cons x xs -> Cons x (append xs b) 41 | -------------------------------------------------------------------------------- /tests/Basic1.hs: -------------------------------------------------------------------------------- 1 | module Basic1 where 2 | 3 | -- data Unit = Unit 4 | 5 | -- id :: a -> a 6 | -- id x = x 7 | 8 | -- ap = id Unit 9 | 10 | twice fn v = fn (fn v) 11 | -------------------------------------------------------------------------------- /tests/Basic1.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: ∀ a. (a → a) → a → a 3 | twice fn v = fn (fn v) 4 | :: a → a 5 | twice fn v = fn (fn v) 6 | :: a 7 | twice fn v = fn (fn v) 8 | 9 | Proofs: 10 | coercion: a → a 11 | twice fn v = fn (fn v) 12 | coercion: a → a 13 | twice fn v = fn (fn v) 14 | coercion: a 15 | twice fn v = fn (fn v) 16 | -------------------------------------------------------------------------------- /tests/Bug1.hs: -------------------------------------------------------------------------------- 1 | module Bug1 where 2 | 3 | unit = (\x -> x) () 4 | -------------------------------------------------------------------------------- /tests/Bug1.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: () 3 | unit = (\x -> x) () 4 | 5 | Proofs: 6 | coercion: () 7 | unit = (\x -> x) () 8 | coercion: () 9 | unit = (\x -> x) () 10 | -------------------------------------------------------------------------------- /tests/Bug2.hs: -------------------------------------------------------------------------------- 1 | module Bug2 where 2 | 3 | list = (\x -> x) [] 4 | -------------------------------------------------------------------------------- /tests/Bug2.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: [a] 3 | list = (\x -> x) [] 4 | 5 | Proofs: 6 | coercion: ∀ a. [a] 7 | list = (\x -> x) [] 8 | coercion: (∀ a. [a]) @ a 9 | list = (\x -> x) [] 10 | coercion: [a] 11 | list = (\x -> x) [] 12 | -------------------------------------------------------------------------------- /tests/Bug3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Bug3 where 3 | 4 | higher :: (forall a. a -> a) -> () 5 | higher id = id () 6 | 7 | bug :: (a -> a) -> () 8 | bug id = higher id 9 | -------------------------------------------------------------------------------- /tests/Bug3.stdout: -------------------------------------------------------------------------------- 1 | UnificationError "Unexpected ref: skolem(a2)" -------------------------------------------------------------------------------- /tests/Class1.hs: -------------------------------------------------------------------------------- 1 | module Class1 where 2 | 3 | data String 4 | 5 | class Show a where 6 | show :: a -> String 7 | 8 | class Monad m where 9 | return :: a -> m a 10 | 11 | list x = return [x] 12 | -------------------------------------------------------------------------------- /tests/Class1.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: * 3 | data String 4 | :: ∀ a. Class1.Show a ⇒ a → Class1.String 5 | show :: a -> String 6 | :: ∀ m a. Class1.Monad m ⇒ a → m a 7 | return :: a -> m a 8 | :: ∀ b a. Class1.Monad b ⇒ a → b [a] 9 | list x = return [x] 10 | :: a 11 | list x = return [x] 12 | 13 | Proofs: 14 | coercion: (∀ a. [a]) @ a 15 | list x = return [x] 16 | coercion: (∀ m a. Class1.Monad m ⇒ a → m a) @ b [a] 17 | list x = return [x] 18 | coercion: a 19 | list x = return [x] 20 | -------------------------------------------------------------------------------- /tests/Class2.hs: -------------------------------------------------------------------------------- 1 | module Class2 where 2 | 3 | data String 4 | data Bool = True | False 5 | 6 | class Show a where 7 | show :: a -> String 8 | 9 | instance Show Bool 10 | 11 | false x = show False 12 | 13 | falseFn x = show (x False) 14 | 15 | show' x = show x 16 | -------------------------------------------------------------------------------- /tests/Class2.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: * 3 | data String 4 | :: * 5 | data Bool = True | False 6 | :: Class2.Bool 7 | data Bool = True | False 8 | :: Class2.Bool 9 | data Bool = True | False 10 | :: ∀ a. Class2.Show a ⇒ a → Class2.String 11 | show :: a -> String 12 | :: ∀ a. a → Class2.String 13 | false x = show False 14 | :: a 15 | false x = show False 16 | :: ∀ a. Class2.Show a ⇒ (Class2.Bool → a) → Class2.String 17 | falseFn x = show (x False) 18 | :: Class2.Bool → a 19 | falseFn x = show (x False) 20 | :: ∀ a. Class2.Show a ⇒ a → Class2.String 21 | show' x = show x 22 | :: a 23 | show' x = show x 24 | 25 | Proofs: 26 | coercion: Class2.Show Class2.Bool 27 | instance Show Bool 28 | coercion: (∀ a. Class2.Show a ⇒ a → Class2.String) @ Class2.Bool 29 | false x = show False 30 | coercion: Class2.Bool 31 | false x = show False 32 | coercion: (∀ a. Class2.Show a ⇒ a → Class2.String) @ a 33 | falseFn x = show (x False) 34 | coercion: Class2.Bool → a 35 | falseFn x = show (x False) 36 | coercion: Class2.Bool 37 | falseFn x = show (x False) 38 | coercion: (∀ a. Class2.Show a ⇒ a → Class2.String) @ a 39 | show' x = show x 40 | coercion: a 41 | show' x = show x 42 | -------------------------------------------------------------------------------- /tests/Class3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitForAll #-} 2 | module Class3 where 3 | 4 | -- Errors: 5 | -- Could not deduce (Show b) from context. 6 | -- Kept contains a skolem variable 7 | -- Example: 8 | -- fn :: Class a => a -> String 9 | -- err :: a -> String 10 | -- err a = fn a 11 | -- No instance for (Show meta_var_10) 12 | -- Kept contains a meta variable 13 | -- Example: 14 | -- fn :: Class a => a -> String 15 | -- err = fn undefined 16 | -- err x = show (read x) -- with no defaulting 17 | -- context too weak 18 | -- Context is not null. 19 | 20 | data String 21 | 22 | -- class Show a where 23 | -- 24 | -- show :: Show a => a -> String 25 | -- show x = show x 26 | 27 | class Super a 28 | class Super a => Sub a 29 | -- class Sub a 30 | instance (Super a, Super b) => Super (a,b) 31 | 32 | super :: Super a => a -> String 33 | super x = super x 34 | 35 | -- sub :: Sub a => a -> String 36 | -- sub x = super x 37 | 38 | -- byInst :: (Super a, Super b) => a -> b -> String 39 | byInst a b = super (a,b) 40 | 41 | -- show' :: (Show a, Show b) => a -> b -> String 42 | -- show' a b = show' a b 43 | 44 | -- Could not deduce (Show b) from context. 45 | -- show2 :: Show a => a -> b -> String 46 | -- show2 a b = show2 b a 47 | 48 | -- undefined :: a -> b 49 | -- undefined x = undefined x 50 | 51 | -- No instance for (Show meta_var_10) 52 | -- err3 :: a -> String 53 | -- err3 x = show' x (undefined x) 54 | 55 | -- context too weak 56 | -- bad :: a -> String 57 | -- bad x = show x 58 | 59 | -- s2s :: String -> String 60 | -- s2s x = s2s x 61 | 62 | -- Signature too general 63 | -- unify 'String' with skolem_a 64 | -- s2any :: String -> a 65 | -- s2any x = s2s x 66 | 67 | -- show' x = show x 68 | 69 | {- 70 | add assumption: show :: forall a. Show a => a -> String 71 | show' :: _A_ 72 | x :: _B_ 73 | _A_ = _B_ -> _C_ 74 | instantiate (forall a. Show a => a -> String) => _D_ -> String 75 | add predicate: Show _D_ 76 | _B_ = _D_ 77 | _C_ = String 78 | _A_ = _D_ -> String 79 | generalize: _A_ => _D_ -> String => forall a. a -> String 80 | Add predicates: forall a. Show a => a -> String 81 | -} 82 | -------------------------------------------------------------------------------- /tests/Class3.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: * 3 | data String 4 | :: ∀ a. Class3.Super a ⇒ a → Class3.String 5 | super x = super x 6 | :: a 7 | super x = super x 8 | :: ∀ a b. (Class3.Super b, Class3.Super a) ⇒ a → b → Class3.String 9 | byInst a b = super (a,b) 10 | :: a 11 | byInst a b = super (a,b) 12 | :: b 13 | byInst a b = super (a,b) 14 | 15 | Proofs: 16 | coercion: ∀ b a. (Class3.Super a, Class3.Super b) ⇒ Class3.Super (a 17 | ,b) 18 | instance (Super a, Super b) => Super (a,b) 19 | coercion: (∀ a. Class3.Super a ⇒ a → Class3.String) @ a 20 | super x = super x 21 | coercion: a 22 | super x = super x 23 | coercion: (∀ a. Class3.Super a ⇒ a → Class3.String) @ (a 24 | ,b) 25 | byInst a b = super (a,b) 26 | coercion: a 27 | byInst a b = super (a,b) 28 | coercion: b 29 | byInst a b = super (a,b) 30 | -------------------------------------------------------------------------------- /tests/Class4.hs: -------------------------------------------------------------------------------- 1 | module Class4 where 2 | 3 | data String 4 | 5 | class Show a where 6 | show :: a -> String 7 | 8 | fn1 x y = (fn2 x, y) 9 | where 10 | fn2 x = show x 11 | -------------------------------------------------------------------------------- /tests/Class4.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: * 3 | data String 4 | :: ∀ a. Class4.Show a ⇒ a → Class4.String 5 | show :: a -> String 6 | :: ∀ a b. Class4.Show a ⇒ a → b → (Class4.String 7 | ,b) 8 | fn1 x y = (fn2 x, y) 9 |  where 10 |  fn2 x = show x 11 | :: a 12 | fn1 x y = (fn2 x, y) 13 | :: b 14 | fn1 x y = (fn2 x, y) 15 | :: ∀ c. Class4.Show c ⇒ c → Class4.String 16 | fn2 x = show x 17 | :: c 18 | fn2 x = show x 19 | 20 | Proofs: 21 | coercion: (∀ c. Class4.Show c ⇒ c → Class4.String) @ a 22 | fn1 x y = (fn2 x, y) 23 | coercion: a 24 | fn1 x y = (fn2 x, y) 25 | coercion: b 26 | fn1 x y = (fn2 x, y) 27 | coercion: (∀ a. Class4.Show a ⇒ a → Class4.String) @ c 28 | fn2 x = show x 29 | coercion: c 30 | fn2 x = show x 31 | -------------------------------------------------------------------------------- /tests/Class5.hs: -------------------------------------------------------------------------------- 1 | module Class5 where 2 | 3 | data Bool = True | False 4 | 5 | class Default a where 6 | def :: a 7 | 8 | instance Default Bool where 9 | def = True 10 | 11 | data Maybe a = Nothing | Just a 12 | instance Default b => Default (Maybe b) where 13 | def = Just def 14 | -------------------------------------------------------------------------------- /tests/Class5.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: * 3 | data Bool = True | False 4 | :: Class5.Bool 5 | data Bool = True | False 6 | :: Class5.Bool 7 | data Bool = True | False 8 | :: ∀ a. Class5.Default a ⇒ a 9 | def :: a 10 | :: * → * 11 | data Maybe a = Nothing | Just a 12 | :: Λa. Class5.Maybe a 13 | data Maybe a = Nothing | Just a 14 | :: Λa. a → Class5.Maybe a 15 | data Maybe a = Nothing | Just a 16 | 17 | Proofs: 18 | coercion: Class5.Default Class5.Bool 19 | instance Default Bool where 20 | coercion: Class5.Bool 21 | def = True 22 | coercion: ∀ b. Class5.Default b ⇒ Class5.Default (Class5.Maybe b) 23 | instance Default b => Default (Maybe b) where 24 | coercion: ∀ b. Class5.Maybe b 25 | def = Just def 26 | coercion: Class5.Bool 27 | def = True 28 | coercion: (∀ a. a → Class5.Maybe a) @ b 29 | def = Just def 30 | coercion: (∀ a. Class5.Default a ⇒ a) @ b 31 | def = Just def 32 | -------------------------------------------------------------------------------- /tests/Class6.hs: -------------------------------------------------------------------------------- 1 | module Class6 where 2 | 3 | class Plus a where 4 | plus :: a -> a -> a 5 | 6 | data Maybe a = Nothing | Just a 7 | 8 | instance Plus (Maybe a) where 9 | plus = \a b -> Nothing 10 | -------------------------------------------------------------------------------- /tests/Class6.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: ∀ a. Class6.Plus a ⇒ a → a → a 3 | plus :: a -> a -> a 4 | :: * → * 5 | data Maybe a = Nothing | Just a 6 | :: Λa. Class6.Maybe a 7 | data Maybe a = Nothing | Just a 8 | :: Λa. a → Class6.Maybe a 9 | data Maybe a = Nothing | Just a 10 | :: Class6.Maybe a 11 | plus = \a b -> Nothing 12 | :: Class6.Maybe a 13 | plus = \a b -> Nothing 14 | 15 | Proofs: 16 | coercion: ∀ a. Class6.Plus (Class6.Maybe a) 17 | instance Plus (Maybe a) where 18 | coercion: ∀ a. Class6.Maybe a → Class6.Maybe a → Class6.Maybe a 19 | plus = \a b -> Nothing 20 | coercion: (∀ a. Class6.Maybe a) @ a 21 | plus = \a b -> Nothing 22 | -------------------------------------------------------------------------------- /tests/Do1.hs: -------------------------------------------------------------------------------- 1 | module Do1 where 2 | 3 | x = do x; x 4 | -------------------------------------------------------------------------------- /tests/InlinePragma.hs: -------------------------------------------------------------------------------- 1 | module InlinePragma where 2 | 3 | {-# NOINLINE x #-} 4 | x () = () 5 | 6 | {-# INLINE y #-} 7 | y () = () 8 | -------------------------------------------------------------------------------- /tests/InlinePragma.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: () → () 3 | x () = () 4 | :: () → () 5 | y () = () 6 | 7 | Proofs: 8 | coercion: () 9 | x () = () 10 | coercion: () 11 | y () = () 12 | -------------------------------------------------------------------------------- /tests/Map.hs: -------------------------------------------------------------------------------- 1 | data List a = Nil | Cons a (List a) 2 | 3 | map :: (a -> b) -> List a -> List b 4 | map f lst = 5 | case lst of 6 | Nil -> Nil 7 | Cons x xs -> Cons (f x) (map f xs) 8 | -------------------------------------------------------------------------------- /tests/Map.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: * → * 3 | data List a = Nil | Cons a (List a) 4 | :: Λa. Main.List a 5 | data List a = Nil | Cons a (List a) 6 | :: Λa. a → Main.List a → Main.List a 7 | data List a = Nil | Cons a (List a) 8 | :: ∀ a b. (a → b) → Main.List a → Main.List b 9 | map f lst = 10 |  case lst of 11 |  Nil -> Nil 12 |  Cons x xs -> Cons (f x) (map f xs) 13 | :: a → b 14 | map f lst = 15 | :: Main.List a 16 | map f lst = 17 | :: a 18 | Cons x xs -> Cons (f x) (map f xs) 19 | :: Main.List a 20 | Cons x xs -> Cons (f x) (map f xs) 21 | 22 | Proofs: 23 | coercion: (∀ a. Main.List a) @ a 24 | Nil -> Nil 25 | coercion: (∀ a. a → Main.List a → Main.List a) @ a 26 | Cons x xs -> Cons (f x) (map f xs) 27 | coercion: Main.List a 28 | case lst of 29 | coercion: (∀ a. Main.List a) @ b 30 | Nil -> Nil 31 | coercion: (∀ a. a → Main.List a → Main.List a) @ b 32 | Cons x xs -> Cons (f x) (map f xs) 33 | coercion: a → b 34 | Cons x xs -> Cons (f x) (map f xs) 35 | coercion: a 36 | Cons x xs -> Cons (f x) (map f xs) 37 | coercion: (∀ a b. (a → b) → Main.List a → Main.List b) @ a b 38 | Cons x xs -> Cons (f x) (map f xs) 39 | coercion: a → b 40 | Cons x xs -> Cons (f x) (map f xs) 41 | coercion: Main.List a 42 | Cons x xs -> Cons (f x) (map f xs) 43 | -------------------------------------------------------------------------------- /tests/Naming1.hs: -------------------------------------------------------------------------------- 1 | module Naming1 where 2 | 3 | fn :: a -> a 4 | fn var_a = sub var_a 5 | where 6 | sub :: a -> a 7 | sub another_a = const var_a another_a 8 | 9 | const :: a -> b -> b 10 | const _ b = b 11 | -------------------------------------------------------------------------------- /tests/Naming1.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: ∀ a. a → a 3 | fn var_a = sub var_a 4 |  where 5 |  sub :: a -> a 6 |  sub another_a = const var_a another_a 7 | :: a 8 | fn var_a = sub var_a 9 | :: ∀ a2. a2 → a2 10 | sub another_a = const var_a another_a 11 | :: a2 12 | sub another_a = const var_a another_a 13 | :: ∀ a b. a → b → b 14 | const _ b = b 15 | :: b 16 | const _ b = b 17 | 18 | Proofs: 19 | coercion: (∀ a. a → a) @ a 20 | fn var_a = sub var_a 21 | coercion: a 22 | fn var_a = sub var_a 23 | coercion: (∀ a b. a → b → b) @ a a2 24 | sub another_a = const var_a another_a 25 | coercion: a 26 | sub another_a = const var_a another_a 27 | coercion: a2 28 | sub another_a = const var_a another_a 29 | coercion: b 30 | const _ b = b 31 | -------------------------------------------------------------------------------- /tests/Naming2.hs: -------------------------------------------------------------------------------- 1 | module Naming2 where 2 | 3 | fn :: a -> a 4 | fn var_a = sub var_a 5 | where 6 | sub :: a -> a 7 | sub another_a = const (const var_a ()) another_a 8 | 9 | const :: a -> b -> b 10 | const _ b = b 11 | -------------------------------------------------------------------------------- /tests/Naming2.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: ∀ a. a → a 3 | fn var_a = sub var_a 4 |  where 5 |  sub :: a -> a 6 |  sub another_a = const (const var_a ()) another_a 7 | :: a 8 | fn var_a = sub var_a 9 | :: ∀ a2. a2 → a2 10 | sub another_a = const (const var_a ()) another_a 11 | :: a2 12 | sub another_a = const (const var_a ()) another_a 13 | :: ∀ a b. a → b → b 14 | const _ b = b 15 | :: b 16 | const _ b = b 17 | 18 | Proofs: 19 | coercion: (∀ a. a → a) @ a 20 | fn var_a = sub var_a 21 | coercion: a 22 | fn var_a = sub var_a 23 | coercion: (∀ a b. a → b → b) @ () a2 24 | sub another_a = const (const var_a ()) another_a 25 | coercion: (∀ a b. a → b → b) @ a () 26 | sub another_a = const (const var_a ()) another_a 27 | coercion: a 28 | sub another_a = const (const var_a ()) another_a 29 | coercion: a2 30 | sub another_a = const (const var_a ()) another_a 31 | coercion: b 32 | const _ b = b 33 | -------------------------------------------------------------------------------- /tests/Naming3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Naming3 where 3 | 4 | fn :: forall b. b -> (forall a. a -> a) 5 | fn b a = a 6 | -------------------------------------------------------------------------------- /tests/Naming3.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: Λb. λ1::b. Λa. ((∀ b a. b → a → a) @ b a) 1 3 | fn b a = a 4 | :: b 5 | fn b a = a 6 | :: a 7 | fn b a = a 8 | 9 | Proofs: 10 | coercion: a 11 | fn b a = a 12 | -------------------------------------------------------------------------------- /tests/Naming4.hs: -------------------------------------------------------------------------------- 1 | module Naming4 where 2 | 3 | {- 4 | fn var_a = sub var_a 5 | where 6 | sub another_a = const var_a another_a 7 | -} 8 | const _ b = b 9 | 10 | {- 11 | outer a = a 12 | where 13 | inner b = b 14 | -} 15 | 16 | outer a = a 17 | where 18 | inner b = const (const a ()) b 19 | id x = x 20 | -------------------------------------------------------------------------------- /tests/Naming4.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: ∀ a b. a → b → b 3 | const _ b = b 4 | :: b 5 | const _ b = b 6 | :: ∀ a. a → a 7 | outer a = a 8 |  where 9 |  inner b = const (const a ()) b 10 |  id x = x 11 | :: a 12 | outer a = a 13 | :: ∀ b. b → b 14 | inner b = const (const a ()) b 15 | :: b 16 | inner b = const (const a ()) b 17 | :: ∀ c. c → c 18 | id x = x 19 | :: c 20 | id x = x 21 | 22 | Proofs: 23 | coercion: b 24 | const _ b = b 25 | coercion: a 26 | outer a = a 27 | coercion: (∀ a b. a → b → b) @ () b 28 | inner b = const (const a ()) b 29 | coercion: (∀ a b. a → b → b) @ a () 30 | inner b = const (const a ()) b 31 | coercion: a 32 | inner b = const (const a ()) b 33 | coercion: b 34 | inner b = const (const a ()) b 35 | coercion: c 36 | id x = x 37 | -------------------------------------------------------------------------------- /tests/Naming5.hs: -------------------------------------------------------------------------------- 1 | module Naming5 where 2 | 3 | outer b = b 4 | where 5 | inner :: a -> a 6 | inner a = const b a 7 | 8 | const _ b = b 9 | -------------------------------------------------------------------------------- /tests/Pattern1.hs: -------------------------------------------------------------------------------- 1 | module Pattern1 where 2 | 3 | data Bool = False | True 4 | 5 | not True = False 6 | not False = True 7 | -------------------------------------------------------------------------------- /tests/Pattern1.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: * 3 | data Bool = False | True 4 | :: Pattern1.Bool 5 | data Bool = False | True 6 | :: Pattern1.Bool 7 | data Bool = False | True 8 | :: Pattern1.Bool → Pattern1.Bool 9 | not True = False 10 | not False = True 11 | 12 | Proofs: 13 | coercion: Pattern1.Bool 14 | not True = False 15 | coercion: Pattern1.Bool 16 | not False = True 17 | coercion: Pattern1.Bool 18 | not True = False 19 | coercion: Pattern1.Bool 20 | not False = True 21 | -------------------------------------------------------------------------------- /tests/Pattern2.hs: -------------------------------------------------------------------------------- 1 | module Pattern2 where 2 | 3 | data Maybe a = Nothing | Just a 4 | 5 | fromMaybe def Nothing = def 6 | fromMaybe def (Just a) = a 7 | -------------------------------------------------------------------------------- /tests/Pattern2.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: * → * 3 | data Maybe a = Nothing | Just a 4 | :: Λa. Pattern2.Maybe a 5 | data Maybe a = Nothing | Just a 6 | :: Λa. a → Pattern2.Maybe a 7 | data Maybe a = Nothing | Just a 8 | :: ∀ a. a → Pattern2.Maybe a → a 9 | fromMaybe def Nothing = def 10 | fromMaybe def (Just a) = a 11 | :: a 12 | fromMaybe def Nothing = def 13 | :: a 14 | fromMaybe def (Just a) = a 15 | :: a 16 | fromMaybe def (Just a) = a 17 | 18 | Proofs: 19 | coercion: (∀ a. Pattern2.Maybe a) @ a 20 | fromMaybe def Nothing = def 21 | coercion: (∀ a. a → Pattern2.Maybe a) @ a 22 | fromMaybe def (Just a) = a 23 | coercion: a 24 | fromMaybe def Nothing = def 25 | coercion: a 26 | fromMaybe def (Just a) = a 27 | -------------------------------------------------------------------------------- /tests/Pattern3.hs: -------------------------------------------------------------------------------- 1 | module Pattern2 where 2 | 3 | data List a = Nil | Cons a (List a) 4 | 5 | drop1 ( x `Cons` xs) = xs 6 | -------------------------------------------------------------------------------- /tests/Pattern3.stdout: -------------------------------------------------------------------------------- 1 | Bindings: 2 | :: * → * 3 | data List a = Nil | Cons a (List a) 4 | :: Λa. Pattern2.List a 5 | data List a = Nil | Cons a (List a) 6 | :: Λa. a → Pattern2.List a → Pattern2.List a 7 | data List a = Nil | Cons a (List a) 8 | :: ∀ a. Pattern2.List a → Pattern2.List a 9 | drop1 ( x `Cons` xs) = xs 10 | :: a 11 | drop1 ( x `Cons` xs) = xs 12 | :: Pattern2.List a 13 | drop1 ( x `Cons` xs) = xs 14 | 15 | Proofs: 16 | coercion: (∀ a. a → Pattern2.List a → Pattern2.List a) @ a 17 | drop1 ( x `Cons` xs) = xs 18 | coercion: Pattern2.List a 19 | drop1 ( x `Cons` xs) = xs 20 | -------------------------------------------------------------------------------- /tests/RankN1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | f :: (forall a. a -> a) -> () 4 | f = f 5 | 6 | k :: forall a b c. a -> b -> c 7 | k = k 8 | 9 | -- test1 = f (\a -> a) 10 | -- test2 = f k 11 | test3 n = f (k n) 12 | -------------------------------------------------------------------------------- /tests/Rec1.hs: -------------------------------------------------------------------------------- 1 | a = a 2 | -------------------------------------------------------------------------------- /tests/Rec2.hs: -------------------------------------------------------------------------------- 1 | a = b 2 | b = a 3 | -------------------------------------------------------------------------------- /tests/Rec3.hs: -------------------------------------------------------------------------------- 1 | a :: a 2 | a = b 3 | b = a b 4 | -------------------------------------------------------------------------------- /tests/Rec4.hs: -------------------------------------------------------------------------------- 1 | data Tuple a b = Tuple a b 2 | 3 | Tuple a b = Tuple b a 4 | -------------------------------------------------------------------------------- /tests/runtests.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Control.Monad (when) 4 | import qualified Data.ByteString.Lazy as BL 5 | import Data.Foldable (foldMap) 6 | import Data.List (nub, sort) 7 | import qualified Data.Text as T 8 | import qualified Data.Text.Encoding as T 9 | import Language.Haskell.Exts hiding (name) 10 | import Language.Haskell.Scope (emptyResolveEnv, resolve) 11 | import qualified Language.Haskell.Scope as Scope 12 | import Language.Haskell.TypeCheck 13 | import qualified Language.Haskell.TypeCheck.Pretty as P 14 | import System.Directory (doesFileExist) 15 | import System.Environment (getArgs) 16 | import System.Exit (ExitCode (..), exitWith) 17 | import System.FilePath (replaceExtension, 18 | takeBaseName) 19 | import System.IO (hPutStrLn, stderr) 20 | import Text.PrettyPrint.ANSI.Leijen (Doc, indent, text, 21 | underline, vsep, (<+>), 22 | (<>)) 23 | import qualified Text.PrettyPrint.ANSI.Leijen as Doc 24 | 25 | import Test.Tasty 26 | import Test.Tasty.ExpectedFailure 27 | import Test.Tasty.Golden 28 | 29 | 30 | main :: IO () 31 | main = do 32 | args <- getArgs 33 | case args of 34 | [path] -> do 35 | exist <- doesFileExist path 36 | when exist $ do 37 | info <- getTcInfo path 38 | case info of 39 | Left err -> do 40 | putStr err 41 | hPutStrLn stderr "" 42 | exitWith (ExitFailure 1) 43 | Right msg -> do 44 | putStr msg 45 | exitWith ExitSuccess 46 | _ -> return () 47 | goldenFiles <- sort <$> findByExtension [".stdout"] "tests" 48 | defaultMain $ testGroup "Tests" 49 | [ (if testName `elem` ignoreList 50 | then ignoreTest 51 | else id) 52 | (goldenVsText testName goldenFile (getTcInfo' testFile)) 53 | | goldenFile <- goldenFiles 54 | , let testFile = replaceExtension goldenFile "hs" 55 | , let testName = takeBaseName goldenFile 56 | ] 57 | where 58 | ignoreList = [] 59 | 60 | getTcInfo' :: FilePath -> IO String 61 | getTcInfo' path = fmap (either id id) (getTcInfo path) 62 | 63 | getTcInfo :: FilePath -> IO (Either String String) 64 | getTcInfo file = do 65 | fileContent <- readFile file 66 | parsed <- parseFile file 67 | case parsed of 68 | ParseFailed position msg -> do 69 | return $ Left $ 70 | show position ++ "\n" ++ 71 | msg 72 | ParseOk thisModule -> do 73 | let (_env, _errs, scoped) = resolve emptyResolveEnv thisModule 74 | case typecheck emptyTcEnv scoped of 75 | Left err -> return $ Left $ show err 76 | Right (typed, _env') -> do 77 | let allTyped = nub $ foldMap getTyped typed 78 | getTyped (Coerced nameInfo src proof) = [(nameInfo, src, proof)] 79 | getTyped _ = [] 80 | 81 | bindings = [ (src, proof) | (Scope.Binding{}, src, proof) <- allTyped ] 82 | builtin = [ (src, proof) | (Scope.None, src, proof) <- allTyped ] 83 | usages = [ (src, proof) | (Scope.Resolved{}, src, proof) <- allTyped ] 84 | 85 | return $ Right $ show $ Doc.vsep $ 86 | [ Doc.text "Bindings:"] ++ 87 | [ text "::" <+> tyMsg Doc.<$$> 88 | ppLocation 2 fileContent srcspan 89 | | (srcspan, proof) <- bindings 90 | , let tyMsg = P.pretty proof 91 | ] ++ 92 | [ Doc.empty, Doc.text "Proofs:"] ++ 93 | [ text "coercion" <> text ":" <+> tyMsg Doc.<$$> 94 | ppLocation 2 fileContent srcspan 95 | | (srcspan, proof) <- builtin ++ usages 96 | , let tyMsg = P.pretty proof ] ++ 97 | [Doc.empty] 98 | 99 | ppLocation :: Int -> String -> SrcSpanInfo -> Doc 100 | ppLocation padding file srcSpanInfo = 101 | indent padding $ vsep $ 102 | case relevantLines of 103 | [] -> [] 104 | [line] -> 105 | let (before, line') = splitAt (beginColumn-1) line 106 | (highlight, after) = splitAt (endColumn-beginColumn) line' 107 | in [text before <> underline (text highlight) <> text after] 108 | (line:rest) -> map (underline . text) (line:rest) 109 | where 110 | relevantLines = take (endLine-beginLine+1) (drop (beginLine-1) (lines file)) 111 | srcSpan = srcInfoSpan srcSpanInfo 112 | beginLine = srcSpanStartLine srcSpan 113 | beginColumn = srcSpanStartColumn srcSpan 114 | endLine = srcSpanEndLine srcSpan 115 | endColumn = srcSpanEndColumn srcSpan 116 | 117 | goldenVsText :: TestName -> FilePath -> IO String -> TestTree 118 | goldenVsText name path gen = 119 | goldenVsStringDiff name (\ref new -> ["diff", ref, new]) path gen' 120 | where 121 | gen' = BL.fromStrict . T.encodeUtf8 . T.pack <$> gen 122 | --------------------------------------------------------------------------------