├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── examples ├── AgdaPrelude.agdai ├── BadRefl.agdai ├── Bias.lp ├── NatElim.lp ├── NatIf3.agda ├── NoSig.agda ├── NoSig.agdai ├── SimplePoly.lp ├── TooFewArgs.agdai └── VecFlip.agdai ├── lambda-pi-plus.cabal ├── src ├── Common.hs ├── Constraint.hs ├── ConstraintBased.hs ├── Language │ ├── LambdaPiPlus.hs │ └── LambdaPiPlus │ │ └── Internals.hs ├── Main.hs ├── PatternUnify │ ├── Check.hs │ ├── ConstraintInfo.hs │ ├── Context.hs │ ├── Kit.hs │ ├── README.txt │ ├── Run.hs │ ├── SolverConfig.hs │ ├── Tm.hs │ ├── TypeGraphStuff.hs │ └── Unify.hs ├── Top │ ├── Constraint.hs │ ├── Constraint │ │ ├── Equality.hs │ │ ├── Information.hs │ │ ├── Polymorphism.hs │ │ └── Qualifier.hs │ ├── Implementation │ │ ├── Basic.hs │ │ ├── FastSubstitution.hs │ │ ├── General.hs │ │ ├── Overloading.hs │ │ ├── SimpleSubstitution.hs │ │ ├── TypeGraph │ │ │ ├── ApplyHeuristics.hs │ │ │ ├── Basics.hs │ │ │ ├── Class.hs │ │ │ ├── ClassMonadic.hs │ │ │ ├── DefaultHeuristics.hs │ │ │ ├── EquivalenceGroup.hs │ │ │ ├── Heuristic.hs │ │ │ ├── Path.hs │ │ │ └── Standard.hs │ │ ├── TypeGraphSubstitution.hs │ │ └── TypeInference.hs │ ├── Interface │ │ ├── Basic.hs │ │ ├── Qualification.hs │ │ ├── Substitution.hs │ │ └── TypeInference.hs │ ├── Monad │ │ ├── Select.hs │ │ └── StateFix.hs │ ├── Ordering │ │ ├── Tree.hs │ │ └── TreeWalk.hs │ ├── Solver.hs │ ├── Solver │ │ ├── Greedy.hs │ │ ├── PartitionCombinator.hs │ │ ├── SwitchCombinator.hs │ │ └── TypeGraph.hs │ ├── Types.hs │ ├── Types │ │ ├── Classes.hs │ │ ├── Kinds.hs │ │ ├── Primitive.hs │ │ ├── Qualification.hs │ │ ├── Quantification.hs │ │ ├── Schemes.hs │ │ ├── Substitution.hs │ │ ├── Synonym.hs │ │ └── Unification.hs │ └── Util │ │ ├── Embedding.hs │ │ ├── Empty.hs │ │ └── Option.hs └── Utils.hs └── thesisExamples ├── AgdaPrelude.agda ├── AgdaPrelude.agdai ├── ArgsWrongOrder.agda ├── ArgsWrongOrder.agdai ├── ArgsWrongOrder.idr ├── ArgsWrongOrder.lp ├── BadRefl.agda ├── BadRefl.agdai ├── BadRefl.ibc ├── BadRefl.idr ├── BadRefl.lp ├── BadReflPost.lp ├── Bias.agda ├── Bias.idr ├── Bias.lp ├── IdrisPrelude.ibc ├── IdrisPrelude.idr ├── PlusReverse.lp ├── TooFewArgs.agda ├── TooFewArgs.ibc ├── TooFewArgs.idr ├── TooFewArgs.lp ├── TooFewArgsWrongType.agda ├── TooFewArgsWrongType.lp ├── TooManyArgs.agda ├── TooManyArgs.idr ├── TooManyArgs.lp ├── VecFlip.agda └── VecFlip.lp /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.dot 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.out 18 | .stack-work/ 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2016, Joseph Eremondi 2 | 3 | Adapted from 4 | 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above 14 | copyright notice, this list of conditions and the following 15 | disclaimer in the documentation and/or other materials provided 16 | with the distribution. 17 | 18 | * Neither the name of Joseph Eremondi nor the names of other 19 | contributors may be used to endorse or promote products derived 20 | from this software without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 23 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 24 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 25 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 26 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 27 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 28 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 29 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 30 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 31 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 32 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Migrated to https://codeberg.org/JoeyEremondi/lambda-pi-constraint 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/AgdaPrelude.agdai: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/JoeyEremondi/lambda-pi-constraint/45e3a6fe2d44e0fa53e6ec464d930ed358974b5a/examples/AgdaPrelude.agdai -------------------------------------------------------------------------------- /examples/BadRefl.agdai: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/JoeyEremondi/lambda-pi-constraint/45e3a6fe2d44e0fa53e6ec464d930ed358974b5a/examples/BadRefl.agdai -------------------------------------------------------------------------------- /examples/Bias.lp: -------------------------------------------------------------------------------- 1 | let symm = 2 | ( \ a -> eqElim a 3 | (\ x y eq_x_y -> Eq a y x) 4 | (\ x -> Refl a x) ) 5 | :: forall (a :: *) (x :: a) (y :: a) . 6 | Eq a x y -> Eq a y x 7 | 8 | let bias = (\ x y -> symm * _ _ (Refl * x) ) :: forall (x :: *) (y :: *) . Eq * x x 9 | -------------------------------------------------------------------------------- /examples/NatElim.lp: -------------------------------------------------------------------------------- 1 | let alwaysZero = 2 | natElim 3 | ( \ _ -> _) -- motive 4 | ( 0 ) -- case for Zero 5 | ( \ _ _ -> 0 ) -- case for Succ 6 | -------------------------------------------------------------------------------- /examples/NatIf3.agda: -------------------------------------------------------------------------------- 1 | module NatIf3 where 2 | 3 | open import Data.Nat 4 | open import Data.Vec 5 | 6 | natIf3 : (a : Set) -> a -> a -> a -> ℕ -> a 7 | natIf3 a x y z zero = x 8 | natIf3 a x y z (suc zero) = y 9 | natIf3 a x y z (suc (suc n)) = z 10 | 11 | nilNat : Vec ℕ 0 12 | nilNat = [] 13 | 14 | --test1 = natIf3 _ 1 nilNat 3 0 15 | 16 | test2 = natIf3 _ nilNat 2 3 0 17 | -------------------------------------------------------------------------------- /examples/NoSig.agda: -------------------------------------------------------------------------------- 1 | module NoSig where 2 | 3 | open import Data.Nat 4 | 5 | myFun : ℕ 6 | myFun = (\ x y -> y ) (\ x -> x) 0 7 | -------------------------------------------------------------------------------- /examples/NoSig.agdai: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/JoeyEremondi/lambda-pi-constraint/45e3a6fe2d44e0fa53e6ec464d930ed358974b5a/examples/NoSig.agdai -------------------------------------------------------------------------------- /examples/SimplePoly.lp: -------------------------------------------------------------------------------- 1 | let myFun = (\ a x y -> x) :: forall (a :: *) . a -> a -> a 2 | 3 | let natNil = Nil Nat 4 | 5 | let myApp = myFun _ natNil 0 6 | -------------------------------------------------------------------------------- /examples/TooFewArgs.agdai: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/JoeyEremondi/lambda-pi-constraint/45e3a6fe2d44e0fa53e6ec464d930ed358974b5a/examples/TooFewArgs.agdai -------------------------------------------------------------------------------- /examples/VecFlip.agdai: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/JoeyEremondi/lambda-pi-constraint/45e3a6fe2d44e0fa53e6ec464d930ed358974b5a/examples/VecFlip.agdai -------------------------------------------------------------------------------- /lambda-pi-plus.cabal: -------------------------------------------------------------------------------- 1 | 2 | name: lambda-pi-plus 3 | version: 0.1.0.0 4 | synopsis: A small dependently-typed language for research and learning purposes. 5 | description: LambdaPiPlus extends the language LambdaPi, from 6 | ["A Tutorial Implementation of a Dependently Typed Lambda Calculus."](https://www.andres-loeh.de/LambdaPi/). 7 | The language has been extended with Dependent Pairs and metavariables, in place of implicit arguments. 8 | The unification algorithm used is adapted from 9 | ["A tutorial implementation of dynamic pattern unification"](http://adam.gundry.co.uk/pub/pattern-unify/). 10 | -- license: 11 | license-file: LICENSE 12 | author: Joey Eremondi 13 | maintainer: joey@eremondi.com 14 | copyright: Joseph Eremondi, 2016 15 | -- category: 16 | build-type: Simple 17 | -- extra-source-files: 18 | cabal-version: >=1.10 19 | 20 | source-repository head 21 | type: git 22 | location: git://github.com/JoeyEremondi/lambda-pi-plus.git 23 | 24 | executable lambda-pi-plus 25 | -- -prof -fprof-auto -fprof-auto -fprof-cafs 26 | ghc-options: 27 | -O2 -Wall -fprof-auto -fprof-auto -fprof-cafs -rtsopts 28 | main-is: Main.hs 29 | other-modules: 30 | ConstraintBased 31 | , Common 32 | , Constraint 33 | , PatternUnify.Check 34 | , PatternUnify.Context 35 | , PatternUnify.Run 36 | , PatternUnify.Tm 37 | , PatternUnify.Unify 38 | , PatternUnify.ConstraintInfo 39 | 40 | , Top.Implementation.TypeGraph.Basics 41 | , Top.Implementation.TypeGraph.Class 42 | , Top.Implementation.TypeGraph.Standard 43 | 44 | 45 | 46 | -- other-extensions: 47 | build-depends: base >=4.7 && <4.9 48 | , mtl 49 | , parsec 50 | , pretty 51 | , containers 52 | , unbound-generics 53 | , transformers 54 | hs-source-dirs: src 55 | default-language: Haskell2010 56 | 57 | -- library 58 | -- -- -prof -fprof-auto -fprof-auto -fprof-cafs 59 | -- ghc-options: 60 | -- -O2 -fwarn-incomplete-patterns -fwarn-unused-imports 61 | -- exposed-modules: 62 | -- Language.LambdaPiPlus 63 | -- other-modules: 64 | -- ConstraintBased, 65 | -- Common, 66 | -- Constraint, 67 | -- Main, 68 | -- PatternUnify.Check, 69 | -- PatternUnify.Context, 70 | -- PatternUnify.Run, 71 | -- PatternUnify.Tm, 72 | -- PatternUnify.Unify, 73 | -- Language.LambdaPiPlus.Internals 74 | -- -- other-extensions: 75 | -- build-depends: base >=4.7 && <4.9 76 | -- , mtl 77 | -- , parsec 78 | -- , pretty 79 | -- , containers 80 | -- , unbound-generics 81 | -- , template-haskell 82 | -- , th-lift 83 | -- hs-source-dirs: src 84 | -- default-language: Haskell2010 85 | -------------------------------------------------------------------------------- /src/Language/LambdaPiPlus.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Language.LambdaPiPlus 5 | ( CompileContext 6 | , ParseResult 7 | , parse 8 | , compile 9 | , initialContext 10 | , noPreludeContext 11 | ) where 12 | 13 | import qualified Language.LambdaPiPlus.Internals as Internal 14 | 15 | import Language.Haskell.TH.Syntax (qRunIO) 16 | 17 | import Common (lpte, lpve) 18 | 19 | import Language.Haskell.TH.Lift 20 | 21 | import PatternUnify.Tm as Tm 22 | 23 | import Text.Parsec.Pos (SourcePos) 24 | 25 | type CompileContext = Internal.CompileContext 26 | type ParseResult = Internal.ParseResult 27 | type Output = String 28 | 29 | noPreludeContext = Internal.emptyContext 30 | 31 | parse :: String -> Either [(Maybe SourcePos, String)] ParseResult 32 | parse = Internal.parse 33 | 34 | compile :: ParseResult -> CompileContext -> Either [(Maybe SourcePos, String)] (CompileContext, Output) 35 | compile = Internal.compile 36 | 37 | initialContext :: CompileContext 38 | initialContext = $( 39 | do 40 | preludeText <- qRunIO $ readFile "prelude.lp" 41 | let 42 | preludeContext = 43 | let 44 | compResult = 45 | do 46 | parseResult <- Internal.parse preludeText 47 | fst <$> Internal.compile parseResult Internal.emptyContext 48 | in 49 | case compResult of 50 | Left e -> error $ "ERROR compiling prelude: " ++ show e 51 | Right ctx -> ctx 52 | [|preludeContext|] 53 | ) 54 | -------------------------------------------------------------------------------- /src/Language/LambdaPiPlus/Internals.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | module Language.LambdaPiPlus.Internals 6 | where 7 | 8 | import Common 9 | import qualified ConstraintBased as CB 10 | import Main 11 | import qualified PatternUnify.Tm as Tm 12 | import Text.Parsec 13 | import Text.Parsec.Pos (SourcePos) 14 | 15 | import Control.Monad.Writer 16 | 17 | import qualified Unbound.Generics.LocallyNameless as LN 18 | 19 | 20 | import Language.Haskell.TH.Lift 21 | 22 | import Control.Monad (foldM) 23 | 24 | type CompileM = Either [(Maybe SourcePos, String)] 25 | 26 | type CompileContext = Common.State Tm.VAL Tm.VAL 27 | type ParseResult = [Stmt ITerm_ CTerm_] 28 | 29 | emptyContext = (True, [], lpve, lpte) 30 | 31 | 32 | int = lp CB.checker 33 | 34 | parse :: String -> CompileM ParseResult 35 | parse source = parseSimple "editor-window" (many (isparse int)) source 36 | 37 | compile :: [Stmt ITerm_ CTerm_] -> CompileContext -> CompileM (CompileContext, String) 38 | compile stmts context = 39 | foldM (doStmt $ lp CB.checker) (context, "") stmts 40 | 41 | 42 | doStmt :: LpInterp 43 | -> (CompileContext, String) -> Stmt ITerm_ CTerm_ -> CompileM (CompileContext, String) 44 | doStmt int (state@(inter, out, ve, te), output) stmt = 45 | do 46 | case stmt of 47 | Assume assm -> foldM (doAssume) (state, output) assm 48 | Let x e -> checkEval x e 49 | Eval e -> checkEval it e 50 | PutStrLn x -> return (state, output ++ x ++"\n") 51 | Out f -> return ((inter, f, ve, te), output) 52 | where 53 | -- checkEval :: String -> i -> IO (State v inf) 54 | checkEval i t = 55 | doCheck int (state, output) i t 56 | (\ (y, v) -> ((inter, "", (Global i, v) : ve, (Global i, ihastype int y) : te))) 57 | 58 | modOutput ident y v subs output = 59 | output 60 | ++ makeOutText int ident y v subs ++ "\n" 61 | ++ solvedMetasString int subs ++ "\n\n" 62 | 63 | doAssume :: (CompileContext, String) -> (String, CTerm_) -> CompileM (CompileContext, String) 64 | doAssume (state@(inter, out, ve, te), output) (x, t) = 65 | doCheck (lp CB.checker) (state, output) x (builtin $ Ann_ t (builtin $ Inf_ $ builtin $ Star_)) 66 | (\ (y, v) -> ((inter, out, ve, (Global x, v) : te))) 67 | 68 | 69 | doCheck :: LpInterp -> (CompileContext, String) -> String -> ITerm_ 70 | -> ((Tm.Type, Tm.VAL) -> CompileContext) -> CompileM (CompileContext, String) 71 | doCheck int (state@(inter, out, ve, te), output) ident t k = 72 | do 73 | -- typecheck and evaluate 74 | (y, newVal, subs) <- iitype int ve te t 75 | let v = ieval int ve t 76 | return (k (y, newVal), modOutput ident y v subs output) 77 | 78 | 79 | $(deriveLiftMany [''Common.Name, ''Common.ITerm_', ''Common.CTerm_', ''Common.Located, ''Common.Region, ''SourcePos, ''LN.Name, ''LN.Bind, ''Tm.Elim, ''Tm.Head, ''Tm.Twin, ''Tm.Can, ''Tm.VAL]) 80 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Common 4 | import qualified ConstraintBased as CB 5 | 6 | import System.Environment (getArgs) 7 | 8 | import PatternUnify.Tm as Tm 9 | 10 | import Constraint as Constraint 11 | 12 | import PatternUnify.Kit 13 | 14 | import Top.Implementation.TypeGraph.Class 15 | 16 | import qualified Data.List as List 17 | import PatternUnify.SolverConfig 18 | import PatternUnify.Tm (Region (..)) 19 | 20 | main :: IO () 21 | main = do 22 | argsWithFlags <- getArgs 23 | let config = SolverConfig (not $ "--noCF" `Prelude.elem` argsWithFlags) (not $ "--noTypeGraph" `Prelude.elem` argsWithFlags) 24 | let args = filter (not . (List.isPrefixOf "--")) argsWithFlags 25 | case args of 26 | [] -> 27 | repLP (CB.checker config) True 28 | (fileName:_) -> do 29 | compileFile (lp $ CB.checker config) (True, [], lpve, lpte) fileName 30 | return () 31 | 32 | type LpInterp = Interpreter ITerm_ CTerm_ Tm.VAL Tm.VAL CTerm_ Tm.VAL 33 | 34 | lp :: TypeChecker -> Interpreter ITerm_ CTerm_ Tm.VAL Tm.VAL CTerm_ Tm.VAL 35 | lp checker = I { iname = "lambda-Pi", 36 | iprompt = "LP> ", 37 | iitype = \ v c -> checker (v, c), 38 | iquote = error "TODO quote", 39 | ieval = \e x -> Constraint.constrEval (lpte, e) x, 40 | ihastype = id, 41 | icprint = cPrint_ 0 0, 42 | itprint = runPretty . pretty, 43 | ivprint = runPretty . pretty, 44 | iiparse = parseITerm_ 0 [], 45 | isparse = parseStmt_ [], 46 | iassume = \ s (x, t) -> lpassume checker s x t } 47 | 48 | 49 | repLP :: TypeChecker -> Bool -> IO () 50 | repLP checker b = readevalprint (lp checker) (b, [], lpve, lpte) 51 | 52 | lpassume checker state@(inter, out, ve, te) x t = 53 | check (lp checker) state x (builtin $ Ann_ t (builtin $ Inf_ $ builtin $ Star_)) 54 | (\ (y, v, _) -> return ()) 55 | (\ (y, v) -> (inter, out, ve, (Global x, v) : te)) 56 | -------------------------------------------------------------------------------- /src/PatternUnify/ConstraintInfo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE PatternSynonyms #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeSynonymInstances #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module PatternUnify.ConstraintInfo where 16 | 17 | 18 | 19 | import Control.Applicative 20 | import Control.Monad.Except 21 | import Control.Monad.Identity 22 | import Control.Monad.Reader 23 | import Control.Monad.State 24 | import qualified Control.Monad.Writer as Writer 25 | 26 | import qualified Data.List as List 27 | import qualified Data.Map as Map 28 | import qualified Data.Maybe as Maybe 29 | 30 | import Debug.Trace (trace) 31 | import GHC.Generics 32 | 33 | import Unbound.Generics.LocallyNameless hiding (join, restrict) 34 | import Unbound.Generics.LocallyNameless.Bind 35 | import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) 36 | --import Unbound.LocallyNameless.Types (GenBind(..)) 37 | 38 | import PatternUnify.Kit 39 | import PatternUnify.Tm 40 | 41 | --import Debug.Trace (trace) 42 | 43 | import Data.List (union) 44 | 45 | import qualified Top.Interface.Basic as Basic 46 | 47 | import qualified Top.Implementation.TypeGraph.ClassMonadic as CM 48 | 49 | import qualified Top.Implementation.TypeGraph.ApplyHeuristics as Heur 50 | 51 | import Top.Solver (LogEntries) 52 | 53 | import PatternUnify.Tm (Region (..)) 54 | import Text.Parsec (SourcePos) 55 | 56 | 57 | newtype ProbId = ProbId {probIdToName :: Nom} 58 | deriving (Eq, Show, Pretty, Generic, Ord) 59 | 60 | data ConstraintInfo = ConstraintInfo 61 | { edgeType :: ConstraintType 62 | , edgeEqnInfo :: EqnInfo 63 | , edgeEqn :: (VAL, VAL) 64 | , typeOfValues :: Type 65 | , maybeHint :: Maybe String 66 | } deriving (Eq, Show, Generic) 67 | 68 | data ProgramContext = 69 | -- AppFnType Region String VAL 70 | AppRetType Region VAL 71 | --App region, argNum, fn type, arg value-type pairs, return type, free vars 72 | | Application Region Int String VAL [(VAL, VAL)] VAL [Nom] 73 | | TypeOfProgram 74 | | VarDecl 75 | | ElimEdge 76 | | SignatureCheck 77 | | FnType 78 | | FnBody 79 | | Ctor 80 | deriving (Eq, Show, Generic) 81 | 82 | applicationEdgeRegion :: ProgramContext -> Maybe Region 83 | --applicationEdgeRegion (AppFnType reg _ _) = Just reg 84 | applicationEdgeRegion (Application reg _ _ _ _ _ _) = Just reg 85 | applicationEdgeRegion (AppRetType reg _) = Just reg 86 | applicationEdgeRegion _ = Nothing 87 | 88 | isRightEdge :: ConstraintType -> Bool 89 | isRightEdge (ChoiceEdge RightChoice _ _) = True 90 | isRightEdge _ = False 91 | 92 | 93 | instance Alpha ProgramContext 94 | 95 | instance Alpha EqnInfo 96 | 97 | 98 | instance Alpha ProbId 99 | instance Subst VAL ProbId 100 | 101 | instance Alpha IsCF 102 | 103 | instance Subst VAL IsCF 104 | 105 | instance Subst VAL ProgramContext where 106 | subst _ _ a = a 107 | substs _ a = a 108 | instance Subst VAL Region where 109 | subst _ _ a = a 110 | substs _ a = a 111 | instance Subst VAL EqnInfo where 112 | subst _ _ a = a 113 | substs _ a = a 114 | 115 | 116 | instance Alpha CreationInfo 117 | --NEVER traverse into cosntraint info for substitution 118 | instance Subst VAL ConstraintInfo where 119 | subst _ _ a = a 120 | substs _ a = a 121 | 122 | data ChoiceEdge = LeftChoice | RightChoice 123 | deriving (Eq, Ord, Show, Generic) 124 | 125 | data ConstraintType = 126 | InitConstr ProbId 127 | | MetaUpdate (Nom, VAL) 128 | -- | DefnUpdate Nom 129 | -- | ProbUpdate ProbId 130 | | DefineMeta Nom 131 | | DerivedEqn ProbId 132 | | ChoiceEdge ChoiceEdge Nom (VAL, VAL) 133 | deriving (Eq, Show, Generic) 134 | 135 | data EqnInfo = 136 | EqnInfo 137 | { creationInfo :: CreationInfo 138 | , infoRegion :: Region 139 | , isCF :: IsCF 140 | , programContext :: ProgramContext 141 | , typeOfString :: String 142 | , initialCreatorId :: Maybe ProbId 143 | } deriving (Eq, Show, Generic) 144 | 145 | 146 | constraintPid :: ConstraintInfo -> Maybe ProbId 147 | constraintPid info = case edgeType info of 148 | InitConstr pid -> Just pid 149 | DerivedEqn pid -> Just pid 150 | _ -> Nothing 151 | 152 | 153 | data CreationInfo = Initial | CreatedBy ProbId 154 | deriving (Eq, Show, Generic) 155 | 156 | data IsCF = Factual | CounterFactual 157 | deriving (Eq, Ord, Show, Generic) 158 | 159 | 160 | 161 | -- choiceInfo reg choice n x y = 162 | -- ConstraintInfo 163 | -- (ChoiceEdge choice n) 164 | -- (EqnInfo Initial reg Factual) 165 | -- (x,y) 166 | -------------------------------------------------------------------------------- /src/PatternUnify/Kit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE PatternSynonyms #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | -- This module defines some basic general purpose kit, in particular 11 | -- backwards lists and a typeclass of things that can be pretty-printed. 12 | 13 | 14 | module PatternUnify.Kit ( bool 15 | , Bwd 16 | , pattern B0 17 | , pattern (:<) 18 | , (<><) 19 | , (<>>) 20 | , trail 21 | , Size(..) 22 | , prettyAt 23 | , prettyLow 24 | , prettyHigh 25 | , wrapDoc 26 | , runPretty 27 | , pp 28 | , ppWith 29 | , Pretty(..) 30 | , between 31 | , commaSep 32 | , module PP 33 | , PatternUnify.Kit.elem 34 | , PatternUnify.Kit.notElem 35 | , bind2 36 | , bind3 37 | , bind4 38 | , bind5 39 | , bind6 40 | , bind7 41 | ) where 42 | 43 | 44 | import Control.Monad.Reader 45 | 46 | import Text.PrettyPrint.HughesPJ as PP hiding (($$)) 47 | import Unbound.Generics.LocallyNameless 48 | 49 | elem :: Eq a => a -> [a] -> Bool 50 | elem x y = x `Prelude.elem` y 51 | 52 | notElem :: Eq a => a -> [a] -> Bool 53 | notElem x y = not $ PatternUnify.Kit.elem x y 54 | 55 | bool :: a -> a -> Bool -> a 56 | bool no yes b = if b then yes else no 57 | 58 | 59 | --data Bwd a = B0 | Bwd a :< a 60 | -- deriving (Eq, Show, Functor, Foldable) 61 | 62 | type Bwd a = [a] 63 | pattern B0 = [] 64 | pattern x :< y = y : x 65 | 66 | (<><) :: Bwd a -> [a] -> Bwd a 67 | xs <>< [] = xs 68 | xs <>< (y : ys) = (xs :< y) <>< ys 69 | 70 | (<>>) :: Bwd a -> [a] -> [a] 71 | B0 <>> ys = ys 72 | (xs :< x) <>> ys = xs <>> (x : ys) 73 | _ <>> _ = undefined 74 | 75 | trail :: Bwd a -> [a] 76 | trail = (<>> []) 77 | 78 | 79 | data Size = ArgSize | AppSize | PiSize | LamSize 80 | deriving (Bounded, Enum, Eq, Ord, Show) 81 | 82 | prettyAt :: 83 | (Pretty a, Applicative m, LFresh m, MonadReader Size m) => Size -> a -> m Doc 84 | prettyAt sz = local (const sz) . pretty 85 | 86 | prettyLow, prettyHigh :: 87 | (Pretty a, Applicative m, LFresh m, MonadReader Size m) => a -> m Doc 88 | prettyLow a = prettyAt minBound a 89 | prettyHigh a = prettyAt maxBound a 90 | 91 | wrapDoc :: MonadReader Size m => Size -> m Doc -> m Doc 92 | wrapDoc dSize md = do 93 | d <- md 94 | curSize <- ask 95 | return $ if dSize > curSize then parens d else d 96 | 97 | runPretty :: ReaderT Size LFreshM a -> a 98 | runPretty = runLFreshM . flip runReaderT maxBound 99 | 100 | pp :: Pretty a => a -> String 101 | pp = render . runPretty . pretty 102 | 103 | ppWith :: (a -> ReaderT Size LFreshM Doc) -> a -> String 104 | ppWith f = render . runPretty . f 105 | 106 | class Pretty a where 107 | pretty :: (Applicative m, LFresh m, MonadReader Size m) => a -> m Doc 108 | 109 | instance Pretty (Name x) where 110 | pretty n = return $ text $ show n --return $ text $ show (name2String n, name2Integer n) 111 | 112 | instance (Pretty a, Pretty b) => Pretty (Either a b) where 113 | pretty (Left x) = (text "Left" <+>) <$> pretty x 114 | pretty (Right y) = (text "Right" <+>) <$> pretty y 115 | 116 | instance Pretty () where 117 | pretty () = return $ text "()" 118 | 119 | between :: Doc -> Doc -> Doc -> Doc 120 | between d x y = x <+> d <+> y 121 | 122 | commaSep :: [Doc] -> Doc 123 | commaSep = hsep . punctuate comma 124 | 125 | --from http://hackage.haskell.org/package/definitive-base-2.3/docs/src/Algebra-Monad-Base.html#bind3 126 | bind2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c 127 | bind2 f a b = join (f<$>a<*>b) 128 | 129 | bind3 :: Monad m => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d 130 | bind3 f a b c = join (f<$>a<*>b<*>c) 131 | 132 | bind4 133 | :: Monad m => 134 | (t -> t1 -> t2 -> t3 -> m b) 135 | -> m t 136 | -> m t1 137 | -> m t2 138 | -> m t3 139 | -> m b 140 | bind4 f ma mb mc md = do 141 | a <- ma 142 | b <- mb 143 | c <- mc 144 | d <- md 145 | f a b c d 146 | 147 | bind5 :: (Monad m) => (t -> t1 -> t2 -> t3 -> t4 -> m b) -> m t -> m t1 -> m t2 -> m t3 -> m t4 -> m b 148 | bind5 f ma mb mc md me = do 149 | a <- ma 150 | b <- mb 151 | c <- mc 152 | d <- md 153 | e <- me 154 | f a b c d e 155 | 156 | 157 | bind6 :: (Monad m) => (t -> t1 -> t2 -> t3 -> t4 -> t5 -> m b) -> m t -> m t1 -> m t2 -> m t3 -> m t4 -> m t5 -> m b 158 | bind6 f ma mb mc md me mf = do 159 | a <- ma 160 | b <- mb 161 | c <- mc 162 | d <- md 163 | e <- me 164 | ff <- mf 165 | f a b c d e ff 166 | 167 | 168 | bind7 :: (Monad m) => (t -> t1 -> t2 -> t3 -> t4 -> t5 -> t6 -> m b) -> m t -> m t1 -> m t2 -> m t3 -> m t4 -> m t5 -> m t6 -> m b 169 | bind7 f ma mb mc md me mf mg = do 170 | a <- ma 171 | b <- mb 172 | c <- mc 173 | d <- md 174 | e <- me 175 | ff <- mf 176 | g <- mg 177 | f a b c d e ff g 178 | -------------------------------------------------------------------------------- /src/PatternUnify/README.txt: -------------------------------------------------------------------------------- 1 | This is the source code accompanying 2 | 3 | A tutorial implementation of dynamic pattern unification 4 | by Adam Gundry and Conor McBride 5 | 6 | 10th July 2012 7 | 8 | 9 | The algorithm presented in the paper is in the file Unify.lhs. Look at 10 | the file Test.lhs to see how to invoke it (via GHCi). Note that a 11 | recent version of GHC is required, with the unbound library and SHE 12 | preprocessor (http://personal.cis.strath.ac.uk/conor.mcbride/pub/she/). 13 | 14 | -------------------------------------------------------------------------------- /src/PatternUnify/Run.hs: -------------------------------------------------------------------------------- 1 | --{-# OPTIONS_GHC -F -pgmF she #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE PatternSynonyms #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeSynonymInstances #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | -- This module defines test cases for the unification algorithm, divided 16 | -- into those which must succeed, those which should block (possibly 17 | -- succeeding partially), and those which must fail. 18 | 19 | module PatternUnify.Run where 20 | 21 | import Unbound.Generics.LocallyNameless 22 | 23 | import PatternUnify.Check 24 | import PatternUnify.Context 25 | import PatternUnify.Kit 26 | import PatternUnify.Tm 27 | import PatternUnify.Unify 28 | 29 | import qualified Data.Either as Either 30 | import qualified Data.Maybe as Maybe 31 | 32 | import qualified Data.List as List 33 | import qualified Data.Map as Map 34 | import qualified Data.Set as Set 35 | 36 | import PatternUnify.SolverConfig 37 | 38 | --import Debug.Trace (trace) 39 | 40 | --import qualified Unbound.Generics.LocallyNameless as LN 41 | 42 | import qualified Data.Graph as Graph 43 | 44 | import qualified Top.Implementation.TypeGraph.Class as TC 45 | import qualified Top.Implementation.TypeGraph.ClassMonadic as CM 46 | import qualified Top.Implementation.TypeGraph.Standard as TG 47 | 48 | import qualified Top.Util.Empty as Empty 49 | 50 | import Top.Implementation.TypeGraph.ApplyHeuristics 51 | import Top.Implementation.TypeGraph.DefaultHeuristics 52 | 53 | import System.IO.Unsafe (unsafePerformIO) 54 | 55 | import PatternUnify.Tm (Region (..)) 56 | 57 | 58 | -- Allocate a fresh name so the counter starts from 1, to avoid clashing 59 | -- with s2n (which generates names with index 0): 60 | 61 | initialise :: Contextual () 62 | initialise = (fresh (s2n "init") :: Contextual (Name VAL)) >> return () 63 | 64 | data ErrorResult = 65 | ErrorResult 66 | { errorContext :: Context 67 | , solverErrs :: [SolverErr] 68 | } 69 | 70 | data SolverErr = StringErr (ProbId, Region, String) | GraphErr [ErrorInfo ConstraintInfo] 71 | 72 | solveEntries :: SolverConfig -> [Entry] -> Either ErrorResult ((), Context) 73 | solveEntries conf !es = 74 | let --intercalate "\n" $ map show es 75 | !initialContextString = render (runPretty (prettyEntries es)) -- ++ "\nRAW:\n" ++ show es 76 | (result, ctx) = --trace ("Initial context:\n" ++ initialContextString ) $ 77 | (runContextual (B0, map Right es, error "initial problem ID", Empty.empty, [], Set.empty, conf) $ do 78 | initialise 79 | ambulando [] [] Map.empty 80 | --validResult <- validate (const True) 81 | badEdges <- applyHeuristics defaultHeuristics 82 | case badEdges of 83 | [] -> validate (\_ -> True) -- $shouldValidate 84 | _ -> return () 85 | setMsg badEdges 86 | return badEdges 87 | ) --Make sure we don't crash 88 | (lcx,rcx,lastProb,_,finalBadEdges,_,_) = unsafePerformIO $ do 89 | let g = (\(_,_,_,g,_,_,_) -> g) ctx 90 | let ourEdges = (\(_,_,_,_,e,_,_) -> e) ctx 91 | writeFile "out.dot" ( 92 | TC.toDot g 93 | -- List.intercalate "\n\n\n" $ 94 | -- map (\(edgeList, _) -> TC.errorDot edgeList g) ourEdges 95 | ) 96 | return ctx 97 | allEntries = lcx ++ (Either.rights rcx) 98 | depGraph = problemDependenceGraph allEntries es 99 | leadingToList = initialsDependingOn depGraph (Maybe.catMaybes $ map getIdent es) [lastProb] 100 | initLoc = case leadingToList of 101 | [] -> lastProb 102 | (i:_) -> i 103 | -- errString err = "ERROR " ++ err -- ++ "\nInitial context:\n" ++ initialContextString ++ "\n<<<<<<<<<<<<<<<<<<<<\n" 104 | -- resultString = case result of 105 | -- Left s -> ">>>>>>>>>>>>>>\nERROR " ++ s ++ "\nInitial context:\n" ++ 106 | -- initialContextString ++ "\n<<<<<<<<<<<<<<<<<<<<\n" 107 | -- ++ "\nErrorGraph " ++ finalStr 108 | -- Right _ -> render $ runPretty $ pretty ctx 109 | in --trace ("\n\n=============\nFinal\n" ++ List.intercalate "\n" (map pp lcx)) $ 110 | case (finalBadEdges, result) of 111 | ([], Left err) -> --trace ("ERR NO EDGES") $ 112 | Left $ ErrorResult ctx [StringErr (initLoc, BuiltinRegion, err)] 113 | ([], Right _) -> 114 | case getContextErrors es ctx of 115 | Left [] -> error "Empty Left from getContextErrors" 116 | Left errList -> Left $ ErrorResult ctx $ map (\(loc, reg, err) -> StringErr (loc, reg, err)) errList 117 | Right x -> Right x 118 | (edgeList, _) -> --trace ("EDGELIST\n " ++ List.intercalate "\n " (map show edgeList)) $ 119 | Left $ ErrorResult ctx [GraphErr edgeList] 120 | 121 | 122 | 123 | 124 | isFailed (Prob _ _ (Failed e) _) = True 125 | isFailed _ = False 126 | 127 | isPending (Prob _ _ (Pending _) _) = True 128 | isPending _ = False 129 | 130 | getIdent (Prob ident _ _ _) = Just ident 131 | getIdent _ = Nothing 132 | 133 | problemDependenceGraph :: [Entry] -> [Entry] -> (Graph.Graph, Graph.Vertex -> (Entry, Nom, [Nom]), Nom -> Maybe Graph.Vertex) 134 | problemDependenceGraph entries startEntries = 135 | let 136 | 137 | failures = filter isFailed entries 138 | allPendings = filter isPending entries 139 | 140 | 141 | 142 | initialIdents = Maybe.catMaybes $ map getIdent startEntries 143 | 144 | isInitial (Prob ident _ _ _) = ident `Prelude.elem` initialIdents 145 | isInitial _ = False 146 | 147 | failEdges pFrom@(Prob idPendingOn _ (Pending pendingOn) _) = 148 | (pFrom, probIdToName idPendingOn, 149 | [ probIdToName idFailed 150 | | (Prob idFailed _ (Failed err) _) <- failures 151 | , idFailed `Prelude.elem` pendingOn 152 | ] 153 | ++ 154 | [ probIdToName idFailed 155 | | (Prob idFailed _ _ _) <- allPendings 156 | , idFailed `Prelude.elem` pendingOn 157 | ]) 158 | failEdges _ = undefined 159 | in 160 | Graph.graphFromEdges $ 161 | [ failEdges p | p <- allPendings] 162 | ++ [(failProb, probIdToName idFailed, []) | failProb@(Prob idFailed _ _ _) <- failures] 163 | 164 | initialsDependingOn :: (Graph.Graph, t, Nom -> Maybe Graph.Vertex) -> [ProbId] -> [ProbId] -> [ProbId] 165 | initialsDependingOn (pendGraph, vertToInfo, infoToVert) initialIdents targetIdents = 166 | let 167 | in 168 | [ (initId) 169 | | initId <- initialIdents 170 | , failId <- targetIdents 171 | , (Just vinit) <- [infoToVert $ probIdToName initId] 172 | , (Just vfail) <- [infoToVert $ probIdToName failId] 173 | , Graph.path pendGraph vinit vfail 174 | ] 175 | 176 | 177 | 178 | getContextErrors :: [Entry] -> Context -> Either [(ProbId, Region, Err)] ((), Context) 179 | getContextErrors startEntries cx@(lcx, rcx, _, _,_,_,_) = do 180 | let leftErrors = getErrorPairs (trail lcx) 181 | rightErrors = getErrorPairs (Either.rights rcx) 182 | case (leftErrors ++ rightErrors) of 183 | [] -> return ((), cx) 184 | ret -> Left ret 185 | where 186 | 187 | getErrorPairs :: [Entry] -> [(ProbId, Region, String)] 188 | getErrorPairs entries = 189 | let 190 | initialIdents = Maybe.catMaybes $ map getIdent startEntries 191 | failures = filter isFailed entries 192 | allPendings = filter isPending entries 193 | 194 | (pendGraph, vertToInfo, infoToVert) = problemDependenceGraph entries startEntries 195 | 196 | failPaths = 197 | [ (initId, infoRegion $ probInfo failProb, err) 198 | | initId <- initialIdents 199 | , (Prob failId failProb (Failed err) _) <- failures 200 | , (Just vinit) <- [infoToVert $ probIdToName initId] 201 | , (Just vfail) <- [infoToVert $ probIdToName failId] 202 | , Graph.path pendGraph vinit vfail 203 | ] 204 | 205 | in 206 | failPaths 207 | -------------------------------------------------------------------------------- /src/PatternUnify/SolverConfig.hs: -------------------------------------------------------------------------------- 1 | module PatternUnify.SolverConfig where 2 | 3 | data SolverConfig = 4 | SolverConfig 5 | { useCF :: Bool 6 | , useTypeGraph :: Bool 7 | } 8 | -------------------------------------------------------------------------------- /src/PatternUnify/TypeGraphStuff.hs: -------------------------------------------------------------------------------- 1 | module PatternUnify.TypeGraphStuff where 2 | 3 | 4 | import PatternUnify.Context 5 | 6 | import qualified Top.Implementation.TypeGraph.Standard as TG 7 | import qualified Top.Implementation.TypeGraph.ClassMonadic as CM 8 | import qualified Top.Implementation.TypeGraph.ApplyHeuristics as Heur 9 | 10 | instance CM.HasTG Contextual ConstraintInfo where 11 | withTypeGraphM f = do 12 | ourGraph <- getGraph 13 | (ret, newGraph) <- f ourGraph 14 | setGraph newGraph 15 | return ret 16 | -------------------------------------------------------------------------------- /src/Top/Constraint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, ExistentialQuantification, 2 | MultiParamTypeClasses, FlexibleInstances, RankNTypes #-} 3 | ----------------------------------------------------------------------------- 4 | -- | License : GPL 5 | -- 6 | -- Maintainer : helium@cs.uu.nl 7 | -- Stability : provisional 8 | -- Portability : non-portable (requires extensions) 9 | -- 10 | -- A data type to represent constraints in general, and a type class for 11 | -- constraints that are solvable. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Top.Constraint where 16 | 17 | import Top.Types (Substitutable(..)) 18 | 19 | type Constraints m = [Constraint m] 20 | data Constraint m = 21 | forall c . (Show c, Substitutable c) => Constraint c (c -> m ()) (c -> m Bool) 22 | 23 | -- |A constraint is solvable if it knows how it can be solved in a certain 24 | -- state (a monadic operation), if it can check afterwards whether the final 25 | -- state satisfies it, and when it can be shown. 26 | class (Show c, Substitutable c, Monad m) => Solvable c m where 27 | solveConstraint :: c -> m () 28 | checkCondition :: c -> m Bool 29 | 30 | -- default definition 31 | checkCondition _ = return True 32 | 33 | instance Show (Constraint m) where 34 | show (Constraint c _ _) = show c 35 | 36 | instance Substitutable (Constraint m) where 37 | ftv (Constraint c _ _) = ftv c 38 | sub |-> (Constraint c f g) = Constraint (sub |-> c) f g 39 | 40 | instance Monad m => Solvable (Constraint m) m where 41 | solveConstraint (Constraint c f _) = f c 42 | checkCondition (Constraint c _ g) = g c 43 | 44 | -- |Lifting a constraint to the Constraint data type. Every instance of 45 | -- the Solvable type class can be lifted. 46 | liftConstraint :: Solvable c m => c -> Constraint m 47 | liftConstraint c = Constraint c solveConstraint checkCondition 48 | 49 | liftConstraints :: Solvable c m => [c] -> Constraints m 50 | liftConstraints = map liftConstraint 51 | 52 | mapConstraint :: (forall a . m1 a -> m2 a) -> Constraint m1 -> Constraint m2 53 | mapConstraint t (Constraint c f g) = Constraint c (t . f) (t . g) 54 | 55 | newtype Operation m = Op_ String 56 | 57 | operation :: Monad m => String -> m () -> Constraint m 58 | operation s m = Constraint (Op_ s) (const m) (const (return True)) 59 | 60 | instance Show (Operation m) where 61 | show (Op_ s) = "<" ++ s ++ ">" 62 | 63 | instance Substitutable (Operation m) where 64 | ftv _ = [] 65 | _ |-> op = op 66 | 67 | -- |If both constraints of type 'a' and 'b' can be solved in a Monad 'm', then 68 | -- 'Either a b' constraints can also be solved in this monad. 69 | instance (Solvable a m, Solvable b m) => Solvable (Either a b) m where 70 | solveConstraint = either solveConstraint solveConstraint 71 | checkCondition = either checkCondition checkCondition 72 | 73 | -- |The data type ConstraintSum is similar to the (standard) Either data type. 74 | -- However, its Show instance is slightly different as the name of the constructor 75 | -- is not shown. 76 | data ConstraintSum f g info 77 | = SumLeft (f info) 78 | | SumRight (g info) 79 | 80 | instance (Show (f info), Show (g info)) => Show (ConstraintSum f g info) where 81 | show = constraintSum show show 82 | 83 | instance (Functor f, Functor g) => Functor (ConstraintSum f g) where 84 | fmap f = constraintSum (SumLeft . fmap f) (SumRight . fmap f) 85 | 86 | instance (Substitutable (f info), Substitutable (g info)) => Substitutable (ConstraintSum f g info) where 87 | (|->) sub = constraintSum (SumLeft . (sub |->)) (SumRight . (sub |->)) 88 | ftv = constraintSum ftv ftv 89 | 90 | instance (Solvable (f info) m, Solvable (g info) m) => Solvable (ConstraintSum f g info) m where 91 | solveConstraint = constraintSum solveConstraint solveConstraint 92 | checkCondition = constraintSum checkCondition checkCondition 93 | 94 | -- |Similar to the 'either' function. 95 | constraintSum :: (f info -> c) -> (g info -> c) -> ConstraintSum f g info -> c 96 | constraintSum f _ (SumLeft a) = f a 97 | constraintSum _ f (SumRight b) = f b 98 | -------------------------------------------------------------------------------- /src/Top/Constraint/Equality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | ----------------------------------------------------------------------------- 9 | 10 | module Top.Constraint.Equality where 11 | 12 | import Top.Types 13 | import Top.Constraint 14 | import Top.Constraint.Information 15 | import Top.Interface.Substitution 16 | import Top.Interface.TypeInference 17 | import Data.List (union) 18 | 19 | data EqualityConstraint info 20 | = Equality Tp Tp info 21 | 22 | -- |The constructor of an equality constraint. 23 | (.==.) :: Tp -> Tp -> info -> EqualityConstraint info 24 | (.==.) = Equality 25 | 26 | instance Show info => Show (EqualityConstraint info) where 27 | show (Equality t1 t2 info) = 28 | let showInfo = " : {" ++ show info ++ "}" 29 | in show t1 ++ " == " ++ show t2 ++ showInfo 30 | 31 | instance Functor EqualityConstraint where 32 | fmap f (Equality t1 t2 info) = 33 | Equality t1 t2 (f info) 34 | 35 | instance Substitutable (EqualityConstraint info) where 36 | sub |-> (Equality t1 t2 info) = Equality (sub |-> t1) (sub |-> t2) info 37 | ftv (Equality t1 t2 _) = ftv t1 `union` ftv t2 38 | 39 | instance ( TypeConstraintInfo info 40 | , HasSubst m info 41 | , HasTI m info 42 | ) => 43 | Solvable (EqualityConstraint info) m 44 | where 45 | solveConstraint (Equality t1 t2 info) = 46 | unifyTerms (equalityTypePair (t1, t2) info) t1 t2 47 | 48 | checkCondition (Equality t1 t2 _) = 49 | do t1' <- applySubst t1 50 | t2' <- applySubst t2 51 | (_ ,syns) <- getTypeSynonyms 52 | return (expandType syns t1' == expandType syns t2') -------------------------------------------------------------------------------- /src/Top/Constraint/Information.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | ----------------------------------------------------------------------------- 4 | -- | License : GPL 5 | -- 6 | -- Maintainer : helium@cs.uu.nl 7 | -- Stability : provisional 8 | -- Portability : non-portable (requires extensions) 9 | ----------------------------------------------------------------------------- 10 | 11 | module Top.Constraint.Information where 12 | 13 | import qualified PatternUnify.Tm as Tm 14 | import Top.Types 15 | 16 | {- 17 | instance TypeConstraintInfo () 18 | instance PolyTypeConstraintInfo () 19 | 20 | instance TypeConstraintInfo String 21 | instance PolyTypeConstraintInfo String 22 | 23 | 24 | class Show info => TypeConstraintInfo info where 25 | equalityTypePair :: (Tm.VAL, Tm.VAL) -> info -> info 26 | ambiguousPredicate :: Predicate -> info -> info 27 | unresolvedPredicate :: Predicate -> info -> info 28 | predicateArisingFrom :: (Predicate, info) -> info -> info 29 | parentPredicate :: Predicate -> info -> info 30 | escapedSkolems :: [Int] -> info -> info 31 | neverDirective :: (Predicate, info) -> info -> info 32 | closeDirective :: (String, info) -> info -> info 33 | disjointDirective :: (String, info) -> (String, info) -> info -> info 34 | 35 | -- default definitions 36 | equalityTypePair _ = id 37 | ambiguousPredicate _ = id 38 | unresolvedPredicate _ = id 39 | predicateArisingFrom _ = id 40 | parentPredicate _ = id 41 | escapedSkolems _ = id 42 | neverDirective _ = id 43 | closeDirective _ = id 44 | disjointDirective _ _ = id 45 | 46 | class TypeConstraintInfo info => PolyTypeConstraintInfo info where 47 | instantiatedTypeScheme :: Forall (Qualification Predicates Tm.VAL) -> info -> info 48 | skolemizedTypeScheme :: ([Tm.VAL], Forall (Qualification Predicates Tm.VAL)) -> info -> info 49 | 50 | -- default definition 51 | instantiatedTypeScheme _ = id 52 | skolemizedTypeScheme _ = id 53 | -} 54 | -------------------------------------------------------------------------------- /src/Top/Constraint/Polymorphism.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | ----------------------------------------------------------------------------- 9 | 10 | module Top.Constraint.Polymorphism where 11 | 12 | import Top.Types hiding (contextReduction) 13 | import Top.Constraint 14 | import Top.Constraint.Equality ( (.==.) ) 15 | import Top.Interface.Basic 16 | import Top.Interface.TypeInference 17 | import Top.Interface.Substitution 18 | import Top.Interface.Qualification 19 | import Top.Constraint.Information 20 | import Data.List (union, intercalate) 21 | 22 | data PolymorphismConstraint info 23 | = Generalize Int (Tps, Tp) info 24 | | Instantiate Tp (Sigma Predicates) info -- or: explicit instance constraint 25 | | Skolemize Tp (Tps, Sigma Predicates) info 26 | | Implicit Tp (Tps, Tp) info 27 | 28 | -- |The constructor of an instantiate (explicit instance) constraint. 29 | (.::.) :: Tp -> Scheme Predicates -> info -> PolymorphismConstraint info 30 | tp .::. s = Instantiate tp (SigmaScheme s) 31 | 32 | instance Show info => Show (PolymorphismConstraint info) where 33 | show constraint = 34 | case constraint of 35 | Generalize sv (monos, tp) info -> 36 | "s" ++ show sv ++ " := Generalize" ++ commaList [show (map TVar (ftv monos)), show tp] ++ showInfo info 37 | Instantiate tp sigma info -> 38 | show tp ++ " := Instantiate" ++ commaList [showQuantors sigma] ++ showInfo info 39 | Skolemize tp (monos, sigma) info -> 40 | show tp ++ " := Skolemize" ++ commaList [show (map TVar (ftv monos)), showQuantors sigma] ++ showInfo info 41 | Implicit t1 (monos, t2) info -> 42 | show t1 ++ " := Implicit" ++ commaList [show (map TVar (ftv monos)), show t2] ++ showInfo info 43 | 44 | where showInfo info = " : {" ++ show info ++ "}" 45 | commaList = par . intercalate ", " 46 | par s = "(" ++ s ++ ")" 47 | 48 | instance Functor PolymorphismConstraint where 49 | fmap f constraint = 50 | case constraint of 51 | Generalize sv pair info -> Generalize sv pair (f info) 52 | Instantiate tp sigma info -> Instantiate tp sigma (f info) 53 | Skolemize tp pair info -> Skolemize tp pair (f info) 54 | Implicit t1 (monos, t2) info -> Implicit t1 (monos, t2) (f info) 55 | 56 | instance Substitutable (PolymorphismConstraint info) where 57 | sub |-> typeConstraint = 58 | case typeConstraint of 59 | Generalize sv (monos, tp) info -> Generalize sv (sub |-> monos, sub |-> tp) info 60 | Instantiate tp sigma info -> Instantiate (sub |-> tp) (sub |-> sigma) info 61 | Skolemize tp pair info -> Skolemize (sub |-> tp) (sub |-> pair) info 62 | Implicit t1 (monos, t2) info -> Implicit (sub |-> t1) (sub |-> monos, sub |-> t2) info 63 | 64 | ftv typeConstraint = 65 | case typeConstraint of 66 | Generalize _ (monos, tp) _ -> ftv monos `union` ftv tp 67 | Instantiate tp sigma _ -> ftv tp `union` ftv sigma 68 | Skolemize tp pair _ -> ftv tp `union` ftv pair 69 | Implicit t1 (monos, t2) _ -> ftv t1 `union` ftv monos `union` ftv t2 70 | 71 | instance ( HasBasic m info 72 | , HasTI m info 73 | , HasSubst m info 74 | , HasQual m info 75 | , PolyTypeConstraintInfo info 76 | ) => 77 | Solvable (PolymorphismConstraint info) m where 78 | solveConstraint constraint = 79 | case constraint of 80 | 81 | Generalize var (m, tp) _ -> 82 | do -- makeConsistent -- done by contextReduction 83 | contextReduction 84 | m' <- applySubst m 85 | tp' <- applySubst tp 86 | changeQualifiers applySubst 87 | scheme <- generalizeWithQualifiers m' tp' 88 | storeTypeScheme var scheme 89 | 90 | Instantiate tp sigma info -> 91 | do scheme <- findScheme sigma 92 | let newInfo = instantiatedTypeScheme scheme info 93 | qtp <- instantiateM scheme 94 | let (ps, itp) = split qtp 95 | proveQualifiers (equalityTypePair (itp, tp) newInfo) ps 96 | pushConstraint $ liftConstraint 97 | (itp .==. tp $ newInfo) 98 | 99 | Skolemize tp (monos, sigma) info -> 100 | do scheme <- findScheme sigma 101 | let newInfo = skolemizedTypeScheme (monos, scheme) info 102 | qtp <- skolemizeFaked (equalityTypePair (tp, tp) newInfo) monos scheme 103 | let (ps, stp) = split qtp 104 | assumeQualifiers (equalityTypePair (tp, tp) newInfo) ps 105 | pushConstraint $ liftConstraint 106 | (tp .==. stp $ newInfo) 107 | 108 | Implicit t1 (monos, t2) info -> 109 | do sv <- getUnique 110 | pushConstraints $ liftConstraints 111 | [ Generalize sv (monos, t2) info 112 | , Instantiate t1 (SigmaVar sv) info 113 | ] -------------------------------------------------------------------------------- /src/Top/Constraint/Qualifier.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | -- 9 | -- Constraints for overloading 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | 14 | module Top.Constraint.Qualifier where 15 | 16 | import Top.Types 17 | import Top.Constraint 18 | import Top.Constraint.Information 19 | import Top.Interface.Qualification 20 | import Data.List 21 | 22 | data ExtraConstraint info 23 | = Prove Predicate info 24 | | Assume Predicate info 25 | 26 | instance Show info => Show (ExtraConstraint info) where 27 | show typeConstraint = 28 | case typeConstraint of 29 | Prove p info -> 30 | "Prove (" ++ intercalate ", " (showQualifiers p) ++ ")" ++ showInfo info 31 | Assume p info -> 32 | "Assume (" ++ intercalate ", " (showQualifiers p) ++ ")" ++ showInfo info 33 | 34 | where showInfo info = " : {" ++ show info ++ "}" 35 | 36 | instance Functor ExtraConstraint where 37 | fmap f typeConstraint = 38 | case typeConstraint of 39 | Prove p info -> Prove p (f info) 40 | Assume p info -> Assume p (f info) 41 | 42 | instance Substitutable (ExtraConstraint info) where 43 | sub |-> typeConstraint = 44 | case typeConstraint of 45 | Prove p info -> Prove (sub |-> p) info 46 | Assume p info -> Assume (sub |-> p) info 47 | 48 | ftv typeConstraint = 49 | case typeConstraint of 50 | Prove p _ -> ftv p 51 | Assume p _ -> ftv p 52 | 53 | instance ( HasQual m info 54 | , PolyTypeConstraintInfo info 55 | ) => 56 | Solvable (ExtraConstraint info) m 57 | where 58 | solveConstraint typeConstraint = 59 | case typeConstraint of 60 | Prove p info -> 61 | proveQualifier info p 62 | 63 | Assume p info -> 64 | assumeQualifier info p -------------------------------------------------------------------------------- /src/Top/Implementation/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses#-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | -- 9 | -- An interface for a monad that constains the most basic operations to 10 | -- solve constraints. Can be reused for all kinds of constraint-based 11 | -- analyses. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | 16 | module Top.Implementation.Basic where 17 | 18 | import Control.Arrow 19 | import Top.Constraint 20 | import Top.Util.Option 21 | import Top.Implementation.General 22 | import Top.Interface.Basic 23 | import Top.Monad.Select 24 | -- import Control.Monad.State 25 | import Top.Util.Embedding 26 | import Top.Util.Empty() 27 | 28 | ------------------------------------------------------------------------ 29 | -- (I) Algebraic data type 30 | 31 | -- |A BasicState is parameterized over the monad in which the constraints can 32 | -- be solved, and over the information that is stored with each constraint. 33 | data BasicState info m = BasicState 34 | { constraints :: Constraints m -- ^ A stack of constraints that is to be solved 35 | , errors :: [(info, ErrorLabel)] -- ^ The detected errors 36 | , conditions :: [(m Bool, String)] -- ^ Conditions to check (for the solved constraints) 37 | , optionStop :: Option Bool -- ^ Discard all remaining constraints after the first error 38 | , optionCheck :: Option Bool 39 | } 40 | 41 | ------------------------------------------------------------------------ 42 | -- (II) Instance of SolveState (Empty, Show) 43 | 44 | instance SolveState (BasicState info m) where 45 | stateName _ = "Basic State" 46 | stateOptions s = [show (optionStop s), show (optionCheck s)] 47 | 48 | -- |An empty BasicState. 49 | instance Empty (BasicState info m) where 50 | empty = BasicState 51 | { constraints = [] 52 | , errors = [] 53 | , conditions = [] 54 | , optionStop = stopOption 55 | , optionCheck = checkOption 56 | } 57 | 58 | instance Show (BasicState info m) where 59 | show s 60 | | null (constraints s) = overview 61 | | otherwise = 62 | unlines $ 63 | ["Constraints", "-----------"] ++ 64 | map ((" "++) . show) (constraints s) ++ 65 | [overview] 66 | where 67 | overview = "("++show (length (constraints s))++" constraints, "++ 68 | show (length (errors s))++" errors, "++ 69 | show (length (conditions s))++" checks)" 70 | 71 | ------------------------------------------------------------------------ 72 | -- (III) Embeddings 73 | 74 | instance Embedded ClassBasic (BasicState info m) (BasicState info m) where embedding = idE 75 | instance Embedded ClassBasic (Fix (BasicState info) x m) (BasicState info m) where embedding = fromFstFixE embedding 76 | 77 | ------------------------------------------------------------------------ 78 | -- (IV) Instance declaration 79 | 80 | instance ( MonadState s m 81 | , Embedded ClassBasic s (BasicState info m) 82 | ) => 83 | HasBasic (SelectFix (BasicState info) m) info where 84 | 85 | -- constraints 86 | pushConstraints xs = 87 | modify (\s -> s { constraints = map (mapConstraint deselectFix) xs ++ constraints s }) 88 | 89 | popConstraint = 90 | do cs <- gets constraints 91 | case cs of 92 | [] -> return Nothing 93 | (x:xs) -> do modify (\s -> s { constraints = xs }) 94 | return (Just (mapConstraint selectFix x)) 95 | 96 | discardConstraints = 97 | modify (\s -> s { constraints = [] }) 98 | 99 | -- errors 100 | addLabeledError label info = 101 | do modify (\s -> s { errors = (info, label) : errors s }) 102 | stop <- getOption stopAfterFirstError 103 | when stop discardConstraints 104 | 105 | getLabeledErrors = 106 | gets errors 107 | 108 | updateErrorInfo f = 109 | do errs <- getLabeledErrors 110 | newErrs <- let g (info, label) = 111 | do newInfo <- f info 112 | return (newInfo, label) 113 | in mapM g errs 114 | modify (\s -> s { errors = newErrs }) 115 | 116 | -- conditions 117 | addCheck text check = 118 | modify (\s -> s { conditions = (deselectFix check, text) : conditions s}) 119 | 120 | getChecks = 121 | gets (map (first selectFix) . conditions) 122 | 123 | stopAfterFirstError = useOption optionStop (\x s -> s { optionStop = x }) 124 | checkConditions = useOption optionCheck (\x s -> s { optionCheck = x }) -------------------------------------------------------------------------------- /src/Top/Implementation/FastSubstitution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | ----------------------------------------------------------------------------- 9 | 10 | module Top.Implementation.FastSubstitution where 11 | 12 | import Top.Types 13 | import Top.Implementation.General 14 | import Top.Util.Embedding 15 | import Top.Monad.Select 16 | import Top.Interface.TypeInference 17 | import Top.Interface.Basic 18 | import Top.Interface.Substitution 19 | import qualified Data.Map as M 20 | import Data.Maybe 21 | import Utils (internalError) 22 | 23 | ------------------------------------------------------------------------ 24 | -- (I) Algebraic data type 25 | 26 | newtype GreedyState info = GreedyState { unGS :: FixpointSubstitution } 27 | 28 | ------------------------------------------------------------------------ 29 | -- (II) Instance of SolveState (Empty, Show) 30 | 31 | instance SolveState (GreedyState info) where 32 | stateName _ = "Greedy Substitution State" 33 | 34 | instance Show (GreedyState info) where 35 | show gs = let FixpointSubstitution hs = unGS gs in show hs -- _ = "" 36 | 37 | instance Empty (GreedyState info) where 38 | empty = GreedyState (FixpointSubstitution M.empty) 39 | 40 | ------------------------------------------------------------------------ 41 | -- (III) Embeddings 42 | 43 | instance Embedded ClassSubst (GreedyState info) (GreedyState info) where embedding = idE 44 | instance Embedded ClassSubst (Simple (GreedyState info) m b) (GreedyState info) where embedding = fromFstSimpleE embedding 45 | 46 | ------------------------------------------------------------------------ 47 | -- (IV) Instance declaration 48 | 49 | instance ( MonadState s m 50 | , HasBasic m info 51 | , HasTI m info 52 | , Embedded ClassSubst s (GreedyState info) 53 | ) => 54 | HasSubst (Select (GreedyState info) m) info where 55 | 56 | makeSubstConsistent = return () 57 | findSubstForVar i = gets (lookupInt i . unGS) 58 | fixpointSubst = gets unGS 59 | 60 | unifyTerms info t1 t2 = 61 | do t1' <- applySubst t1 62 | t2' <- applySubst t2 63 | synonyms <- select getTypeSynonyms 64 | 65 | case mguWithTypeSynonyms synonyms t1' t2' of 66 | Left _ -> select (addLabeledError unificationErrorLabel info) 67 | Right (used,sub) -> 68 | let mutp = equalUnderTypeSynonyms synonyms (sub |-> t1') (sub |-> t2') 69 | utp = fromMaybe err mutp 70 | err = internalError "Top.Solvers.GreedySubst" "greedyState" "types not unifiable" 71 | f (FixpointSubstitution fm) = 72 | FixpointSubstitution (M.fromList [ (i, lookupInt i sub) | i <- dom sub ] `M.union` fm) 73 | g = writeExpandedType synonyms t2 utp 74 | . writeExpandedType synonyms t1 utp 75 | h = if used then g . f else f 76 | in modify (GreedyState . h . unGS) 77 | 78 | -- The key idea is as follows: 79 | -- try to minimize the number of expansions by type synonyms. 80 | -- If a type is expanded, then this should be recorded in the substitution. 81 | -- Invariant of this function should be that "atp" (the first type) can be 82 | -- made equal to "utp" (the second type) with a number of type synonym expansions 83 | writeExpandedType :: OrderedTypeSynonyms -> Tp -> Tp -> FixpointSubstitution -> FixpointSubstitution 84 | writeExpandedType synonyms = writeTypeType where 85 | 86 | writeTypeType :: Tp -> Tp -> FixpointSubstitution -> FixpointSubstitution 87 | writeTypeType atp utp original = 88 | case (leftSpine atp,leftSpine utp) of 89 | ((TVar i,[]),_) -> 90 | writeIntType i utp original 91 | 92 | ((TCon s,as),(TCon t,bs)) 93 | | s == t && not (isPhantomTypeSynonym synonyms s) -> 94 | foldr (uncurry writeTypeType) original (zip as bs) 95 | 96 | ((TCon _, _),_) -> 97 | case expandTypeConstructorOneStep (snd synonyms) atp of 98 | Just atp' -> writeTypeType atp' utp original 99 | Nothing -> internalError "Top.Solvers.GreedySubst" "writeTypeType" ("inconsistent types(1)" ++ show (atp, utp)) 100 | 101 | _ -> internalError "Top.Solvers.GreedySubst" "writeTypeType" ("inconsistent types(2)" ++ show (atp, utp)) 102 | 103 | writeIntType :: Int -> Tp -> FixpointSubstitution -> FixpointSubstitution 104 | writeIntType i utp original@(FixpointSubstitution fm) = 105 | case M.lookup i fm of 106 | 107 | Nothing -> 108 | case utp of 109 | TVar j | i == j -> original 110 | _ -> FixpointSubstitution (M.insert i utp fm) 111 | 112 | Just atp -> 113 | case (leftSpine atp,leftSpine utp) of 114 | ((TVar j,[]),_) -> writeIntType j utp original 115 | ((TCon s,as),(TCon t,bs)) | s == t -> foldr (uncurry writeTypeType) original (zip as bs) 116 | ((TCon _, _), _) -> case expandTypeConstructorOneStep (snd synonyms) atp of 117 | Just atp' -> writeIntType i utp (FixpointSubstitution (M.insert i atp' fm)) 118 | Nothing -> -- FIX!!! HERSCHRIJVEN! 119 | -- de volgende situatie trad op: 120 | -- utp=Categorie, atp = [Char] 121 | -- met type Categorie = String 122 | case expandTypeConstructorOneStep (snd synonyms) utp of 123 | Just utp' -> 124 | writeIntType i atp (FixpointSubstitution (M.insert i utp' fm)) 125 | Nothing -> 126 | internalError "Top.Solvers.GreedySubst" "writeIntType" ("inconsistent types(1)" ++ show (i, utp, atp)) 127 | _ -> internalError "Top.Solvers.GreedySubst" "writeIntType" "inconsistent types(2)" -------------------------------------------------------------------------------- /src/Top/Implementation/General.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, FlexibleInstances, KindSignatures, 2 | MultiParamTypeClasses #-} 3 | ----------------------------------------------------------------------------- 4 | -- | License : GPL 5 | -- 6 | -- Maintainer : helium@cs.uu.nl 7 | -- Stability : provisional 8 | -- Portability : non-portable (requires extensions) 9 | ----------------------------------------------------------------------------- 10 | 11 | module Top.Implementation.General 12 | ( module Top.Implementation.General 13 | , module Top.Util.Empty 14 | ) where 15 | 16 | import Top.Util.Embedding 17 | import Top.Util.Empty 18 | import Top.Monad.Select 19 | 20 | class (Show s, Empty s) => SolveState s where 21 | showState :: s -> String 22 | stateName :: s -> String 23 | stateOptions :: s -> [String] 24 | collectStates :: s -> [(String, String)] 25 | 26 | showState = show 27 | stateOptions _ = [] 28 | collectStates s = [(stateName s, showState s)] 29 | 30 | instance SolveState () where 31 | stateName _ = "EmptyState" 32 | collectStates _ = [] 33 | 34 | allStates :: (MonadState s m, SolveState s) => m [(String, String)] 35 | allStates = gets collectStates 36 | 37 | allOptions :: (MonadState s m, SolveState s) => m [String] 38 | allOptions = gets stateOptions 39 | 40 | ---------------------- 41 | -- New 42 | 43 | -- ToDo: replace And by infix type constructor (:^:) 44 | -- ToDo: kind annotations for And, Simple, Fix 45 | -- infixr 7 :^: 46 | 47 | data And f g x (m :: * -> *) = Compose (f (g x m) m) 48 | data Simple a x (m :: * -> *) = Simple a x 49 | data Fix g x (m :: * -> *) = Fix (g m) x 50 | 51 | --- Empty 52 | instance Empty (f (g x m) m) => Empty (And f g x m) where 53 | empty = Compose empty 54 | 55 | instance (Empty a, Empty x) => Empty (Simple a x m) where 56 | empty = Simple empty empty 57 | 58 | instance (Empty (g m), Empty x) => Empty (Fix g x m) where 59 | empty = Fix empty empty 60 | 61 | -- Show 62 | instance Show (f (g x m) m) => Show (And f g x m) where 63 | show (Compose a) = show a 64 | 65 | instance (Show a, Show x) => Show (Simple a x m) where 66 | show (Simple a x) = show (a, x) 67 | 68 | instance (Show (f m), Show x) => Show (Fix f x m) where 69 | show (Fix a x) = show (a, x) 70 | 71 | -- SolveState 72 | instance SolveState (f (g x m) m) => SolveState (And f g x m) where 73 | showState (Compose a) = showState a 74 | stateName (Compose a) = stateName a 75 | stateOptions (Compose a) = stateOptions a 76 | collectStates (Compose a) = collectStates a 77 | 78 | instance (SolveState a, SolveState x) => SolveState (Simple a x m) where 79 | showState (Simple a x) = show (a, x) 80 | stateName (Simple a x) = concat ["(", stateName a, ",", stateName x, ")"] 81 | stateOptions (Simple a x) = stateOptions a ++ stateOptions x 82 | collectStates (Simple a x) = collectStates a ++ collectStates x 83 | 84 | instance (SolveState (f m), SolveState x) => SolveState (Fix f x m) where 85 | showState (Fix a x) = show (a, x) 86 | stateName (Fix a x) = concat ["(", stateName a, ",", stateName x, ")"] 87 | stateOptions (Fix a x) = stateOptions a ++ stateOptions x 88 | collectStates (Fix a x) = collectStates a ++ collectStates x 89 | 90 | -- Embedded 91 | instance {-# OVERLAPPABLE #-} Embedded c (f (g x m) m) s => Embedded c (And f g x m) s where 92 | embedding = composeE Embedding { getE = \(Compose a) -> a, changeE = \f (Compose a) -> Compose (f a) } embedding 93 | 94 | instance {-# OVERLAPPABLE #-} Embedded c x s => Embedded c (Simple a x m) s where 95 | embedding = composeE Embedding { getE = \(Simple _ b) -> b, changeE = \f (Simple a b) -> Simple a (f b) } embedding 96 | 97 | instance {-# OVERLAPPABLE #-} Embedded c x s => Embedded c (Fix a x m) s where 98 | embedding = composeE Embedding { getE = \(Fix _ b) -> b, changeE = \f (Fix a b) -> Fix a (f b) } embedding 99 | 100 | fromFstFixE :: Embedding (g m) c -> Embedding (Fix g x m) c 101 | fromFstFixE = composeE Embedding { getE = \(Fix a _) -> a, changeE = \f (Fix a b) -> Fix (f a) b } 102 | 103 | fromFstSimpleE :: Embedding a c -> Embedding (Simple a x m) c 104 | fromFstSimpleE = composeE fstSimpleE 105 | 106 | fstSimpleE :: Embedding (Simple a x m) a 107 | fstSimpleE = Embedding { getE = \(Simple a _) -> a, changeE = \f (Simple a b) -> Simple (f a) b } -------------------------------------------------------------------------------- /src/Top/Implementation/SimpleSubstitution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | ----------------------------------------------------------------------------- 9 | 10 | module Top.Implementation.SimpleSubstitution where 11 | 12 | import Top.Types 13 | import Top.Implementation.General 14 | import Top.Interface.Substitution 15 | import Top.Interface.TypeInference 16 | import Top.Interface.Basic 17 | import Top.Monad.Select 18 | import Top.Util.Embedding 19 | import Top.Util.Empty() 20 | 21 | ------------------------------------------------------------------------ 22 | -- (I) Algebraic data type 23 | 24 | newtype SimpleState info = SimpleState { unSS :: MapSubstitution } 25 | 26 | ------------------------------------------------------------------------ 27 | -- (II) Instance of SolveState (Empty, Show) 28 | 29 | instance SolveState (SimpleState info) where 30 | stateName _ = "Simple Substitution State" 31 | 32 | instance Show (SimpleState info) where 33 | show _ = "" 34 | 35 | instance Empty (SimpleState info) where 36 | empty = SimpleState emptySubst 37 | 38 | ------------------------------------------------------------------------ 39 | -- (III) Embeddings 40 | 41 | instance Embedded ClassSubst (SimpleState info) (SimpleState info) where embedding = idE 42 | instance Embedded ClassSubst (Simple (SimpleState info) x m) (SimpleState info) where embedding = fromFstSimpleE embedding 43 | 44 | ------------------------------------------------------------------------ 45 | -- (IV) Instance declaration 46 | 47 | instance ( MonadState s m 48 | , HasBasic m info 49 | , HasTI m info 50 | , Embedded ClassSubst s (SimpleState info) 51 | ) => 52 | HasSubst (Select (SimpleState info) m) info where 53 | 54 | makeSubstConsistent = 55 | return () 56 | 57 | unifyTerms info t1 t2 = 58 | do synonyms <- select getTypeSynonyms 59 | t1' <- applySubst t1 60 | t2' <- applySubst t2 61 | case mguWithTypeSynonyms synonyms t1' t2' of 62 | Right (_, sub) -> 63 | modify (SimpleState . (sub @@) . unSS) 64 | Left _ -> select (addLabeledError unificationErrorLabel info) 65 | 66 | findSubstForVar i = 67 | gets (lookupInt i . unSS) 68 | 69 | fixpointSubst = 70 | gets (FixpointSubstitution . unSS) -------------------------------------------------------------------------------- /src/Top/Implementation/TypeGraph/Basics.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | ----------------------------------------------------------------------------- 8 | 9 | module Top.Implementation.TypeGraph.Basics where 10 | 11 | import Top.Implementation.TypeGraph.Path 12 | --import Top.Types 13 | import Utils (internalError) 14 | -- import Data.Maybe 15 | import Data.List (intercalate, partition, sort) 16 | import qualified PatternUnify.Tm as Tm 17 | import qualified Unbound.Generics.LocallyNameless as Ln 18 | 19 | ----------------------------------------------------------------------------------------- 20 | 21 | data Constant = Con Tm.Can | ConElim Tm.CanElim | CApp | BoundVar Tm.Nom | NeutralTerm Tm.OrderedNeutral 22 | deriving (Eq, Ord, Show) 23 | 24 | constantToTerm :: Constant -> Tm.VAL 25 | constantToTerm c = error "TODO CTT" 26 | 27 | newtype VertexId = VertexId Tm.Nom deriving (Eq, Ord) 28 | type VertexInfo = (VertexKind, Maybe Tm.VAL) 29 | data VertexKind = 30 | VVar 31 | | VCon Constant 32 | | VTerm 33 | | VApp VertexId VertexId 34 | | VertBot 35 | deriving (Show, Eq, Ord) 36 | 37 | instance Show VertexId where 38 | show (VertexId i) = show i 39 | 40 | vertexIdToTp :: VertexId -> Tm.VAL 41 | vertexIdToTp (VertexId i) = Tm.var i 42 | 43 | data EdgeId = EdgeId VertexId VertexId EdgeNr 44 | newtype EdgeNr = EdgeNrX Tm.Nom deriving (Eq, Ord) 45 | data ChildSide = LeftChild | RightChild 46 | deriving (Eq, Ord) 47 | 48 | makeEdgeNr :: Tm.Nom -> EdgeNr 49 | makeEdgeNr = EdgeNrX 50 | 51 | impliedEdgeNr :: EdgeNr 52 | impliedEdgeNr = makeEdgeNr $ Ln.s2n (show $ -1) 53 | 54 | instance Show EdgeNr where 55 | show (EdgeNrX i) = '#':show i 56 | 57 | instance Show ChildSide where 58 | show LeftChild = "(l)" 59 | show RightChild = "(r)" 60 | 61 | data ParentChild = ParentChild { parent :: VertexId, child :: VertexId, childSide :: ChildSide } 62 | deriving Eq 63 | 64 | instance Show ParentChild where 65 | show pc = show (child pc) ++ " <- " ++ show (parent pc) ++ show (childSide pc) 66 | 67 | instance Ord ParentChild where 68 | compare pc1 pc2 = compare (child pc1, parent pc1) (child pc2, parent pc2) 69 | 70 | type TypeGraphPath info = Path (EdgeId, PathStep info) 71 | data PathStep info 72 | = Initial info 73 | | Implied ChildSide VertexId VertexId 74 | | Child ChildSide 75 | 76 | instance Show (PathStep info) where 77 | show (Initial _) = "Initial" 78 | show (Implied cs x y) = "(" ++ show cs ++ " : " ++ show (x, y) ++ ")" 79 | show (Child i) = "(" ++ show i ++ ")" 80 | 81 | instance Show EdgeId where 82 | show (EdgeId a b _) = "("++show a'++"-"++show b'++")" 83 | where (a',b') = if a <= b then (a,b) else (b,a) 84 | 85 | instance Eq EdgeId where -- why not compare the edge numbers here? 86 | EdgeId a b _ == EdgeId c d _ = (a == c && b == d) || (a == d && b == c) 87 | 88 | instance Ord EdgeId where 89 | EdgeId a b _ <= EdgeId c d _ = order (a,b) <= order (c,d) 90 | where order (i,j) = if i <= j then (i,j) else (j,i) 91 | 92 | -- A clique is a set of vertices that are equivalent because their parents are equal 93 | -- Invariant: a clique cannot be empty 94 | newtype Clique = CliqueX [ParentChild] 95 | type CliqueList = [Clique] 96 | 97 | instance Show Clique where 98 | show (CliqueX xs) = "{" ++ intercalate ", " (map show xs) ++ "}" 99 | 100 | instance Eq Clique where 101 | CliqueX xs == CliqueX ys = 102 | xs == ys 103 | 104 | instance Ord Clique where 105 | compare (CliqueX xs) (CliqueX ys) = compare xs ys 106 | 107 | isSubsetClique :: Clique -> Clique -> Bool 108 | isSubsetClique (CliqueX as) (CliqueX bs) = rec as bs 109 | where 110 | rec [] _ = True 111 | rec _ [] = False 112 | rec a@(x:xs) (y:ys) 113 | | x == y = rec xs ys 114 | | x > y = rec a ys 115 | | otherwise = False 116 | 117 | isDisjointClique :: Clique -> Clique -> Bool 118 | isDisjointClique (CliqueX as) (CliqueX bs) = rec as bs 119 | where 120 | rec [] _ = True 121 | rec _ [] = True 122 | rec a@(x:xs) b@(y:ys) 123 | | x == y = False 124 | | x > y = rec a ys 125 | | otherwise = rec xs b 126 | 127 | cliqueRepresentative :: Clique -> VertexId 128 | cliqueRepresentative (CliqueX xs) = 129 | case xs of 130 | [] -> internalError "Top.TypeGraph.Basics" "cliqueRepresentative" "A clique cannot be empty" 131 | x:_ -> child x 132 | 133 | triplesInClique :: Clique -> [ParentChild] 134 | triplesInClique (CliqueX xs) = xs 135 | 136 | childrenInClique :: Clique -> [VertexId] 137 | childrenInClique = map child . triplesInClique 138 | 139 | mergeCliques :: CliqueList -> Clique 140 | mergeCliques list = CliqueX (foldr op [] [ xs | CliqueX xs <- list ]) 141 | where 142 | op xs [] = xs 143 | op [] ys = ys 144 | op a@(x:xs) b@(y:ys) 145 | | x < y = x : op xs b 146 | | x == y = x : op xs ys 147 | | otherwise = y : op a ys 148 | 149 | makeClique :: [ParentChild] -> Clique 150 | makeClique list 151 | | length set < 2 = internalError "Top.TypeGraph.Basics" "makeClique" "incorrect clique" 152 | | otherwise = CliqueX set 153 | where 154 | set = sort list 155 | 156 | combineCliqueList :: CliqueList -> CliqueList -> CliqueList 157 | combineCliqueList [] ys = ys 158 | combineCliqueList (x:xs) ys = 159 | let (ys1, ys2) = partition (isDisjointClique x) ys 160 | in mergeCliques (x:ys2) : combineCliqueList xs ys1 161 | -------------------------------------------------------------------------------- /src/Top/Implementation/TypeGraph/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | ----------------------------------------------------------------------------- 4 | -- | License : GPL 5 | -- 6 | -- Maintainer : helium@cs.uu.nl 7 | -- Stability : provisional 8 | -- Portability : non-portable (requires extensions) 9 | ----------------------------------------------------------------------------- 10 | 11 | module Top.Implementation.TypeGraph.Class where 12 | 13 | import Data.List (nub) 14 | import Data.Maybe 15 | import qualified Data.Set as S 16 | import Top.Implementation.TypeGraph.Basics 17 | --import Top.Types 18 | import Utils (internalError) 19 | 20 | import qualified PatternUnify.Tm as Tm 21 | import qualified Unbound.Generics.LocallyNameless as Ln 22 | 23 | class TypeGraph graph info | graph -> info where 24 | 25 | -- construct a type graph 26 | addTermGraph :: (Ln.Fresh m) => Tm.Subs -> Tm.Nom -> Tm.VAL -> graph -> m (VertexId, graph) 27 | addVertex :: VertexId -> VertexInfo -> graph -> graph 28 | addEdge :: EdgeId -> info -> graph -> graph 29 | addNewEdge :: (Ln.Fresh m) => (VertexId, VertexId) -> info -> graph -> m graph 30 | 31 | -- deconstruct a type graph 32 | deleteEdge :: EdgeId -> graph -> graph 33 | 34 | choiceInfo :: graph -> info 35 | 36 | -- inspect an equivalence group in a type graph 37 | verticesInGroupOf :: VertexId -> graph -> [(VertexId, VertexInfo)] 38 | childrenInGroupOf :: VertexId -> graph -> ([ParentChild], [ParentChild]) 39 | constantsInGroupOf :: VertexId -> graph -> [Constant] 40 | representativeInGroupOf :: VertexId -> graph -> VertexId 41 | edgesFrom :: VertexId -> graph -> [(EdgeId, info)] 42 | 43 | -- query a path in an equivalence group 44 | allPaths :: VertexId -> VertexId -> graph -> TypeGraphPath info 45 | allPathsList :: VertexId -> [VertexId] -> graph -> TypeGraphPath info 46 | allPathsListWithout :: S.Set VertexId -> VertexId -> [VertexId] -> graph -> TypeGraphPath info 47 | 48 | allEdges :: graph -> [(EdgeId, info)] 49 | 50 | -- substitution and term graph 51 | substituteVariable :: Tm.Subs -> Tm.Nom -> graph -> Tm.VAL 52 | substituteType :: Tm.Subs -> Tm.VAL -> graph -> Tm.VAL 53 | substituteTypeSafe :: Tm.Subs -> Tm.VAL -> graph -> Maybe Tm.VAL 54 | makeSubstitution :: Tm.Subs -> graph -> [(VertexId, Tm.VAL)] 55 | typeFromTermGraph :: VertexId -> graph -> Tm.VAL 56 | 57 | -- Extra administration 58 | markAsPossibleError :: VertexId -> graph -> graph 59 | getMarkedPossibleErrors :: graph -> [VertexId] 60 | unmarkPossibleErrors :: graph -> graph 61 | 62 | getEdgeCreator :: graph -> (EdgeId, info) -> Maybe (EdgeId, info) 63 | 64 | toDot :: graph -> String 65 | errorDot :: [EdgeId] -> graph -> String 66 | 67 | recordVar :: Tm.Nom -> Tm.Param -> graph -> graph 68 | getVarTypes :: graph -> [(Tm.Nom, Tm.Param)] 69 | 70 | ------------------------------------------- 71 | -- default definitions 72 | 73 | allPaths i1 i2 = 74 | allPathsList i1 [i2] 75 | 76 | allPathsList = 77 | allPathsListWithout S.empty 78 | 79 | childrenInGroupOf i graph = 80 | unzip [ ( ParentChild { parent=p, child = t1, childSide=LeftChild } 81 | , ParentChild { parent=p, child = t2, childSide=RightChild } 82 | ) 83 | | (p, (VApp t1 t2, _)) <- verticesInGroupOf i graph 84 | ] 85 | 86 | constantsInGroupOf i graph = 87 | nub [ s | (_, (VCon s, _)) <- verticesInGroupOf i graph ] 88 | 89 | 90 | representativeInGroupOf i graph = 91 | case verticesInGroupOf i graph of 92 | (vid, _):_ -> vid 93 | _ -> internalError "Top.TypeGraph.TypeGraphState" "representativeInGroupOf" "unexpected empty equivalence group" 94 | 95 | substituteVariable syns = 96 | substituteType syns . Tm.var 97 | 98 | substituteType syns tp graph = 99 | let err = internalError "Top.TypeGraph.TypeGraphState" "substituteType" "inconsistent state" 100 | in fromMaybe err (substituteTypeSafe syns tp graph) 101 | 102 | -- Extra administration 103 | markAsPossibleError _ = id 104 | getMarkedPossibleErrors _ = [] 105 | unmarkPossibleErrors = id 106 | -------------------------------------------------------------------------------- /src/Top/Implementation/TypeGraph/ClassMonadic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | ----------------------------------------------------------------------------- 8 | -- | License : GPL 9 | -- 10 | -- Maintainer : helium@cs.uu.nl 11 | -- Stability : provisional 12 | -- Portability : non-portable (requires extensions) 13 | ----------------------------------------------------------------------------- 14 | 15 | module Top.Implementation.TypeGraph.ClassMonadic where 16 | 17 | import qualified Data.Map as M 18 | import qualified Data.Set as S 19 | import qualified PatternUnify.Tm as Tm 20 | import Top.Implementation.TypeGraph.Basics 21 | import qualified Top.Implementation.TypeGraph.Class as TG 22 | import Top.Interface.Basic 23 | import Top.Interface.Qualification 24 | import Top.Interface.TypeInference 25 | import Top.Solver 26 | import qualified Unbound.Generics.LocallyNameless as Ln 27 | 28 | class (HasBasic m info, {-HasTI m info, HasQual m info,-} HasTG m info, MonadWriter LogEntries m, Show info) => HasTypeGraph m info | m -> info 29 | 30 | instance (HasBasic m info, {-HasTI m info, HasQual m info,-} HasTG m info, MonadWriter LogEntries m, Show info) => HasTypeGraph m info 31 | 32 | class Monad m => HasTG m info | m -> info where 33 | withTypeGraph :: (forall graph . TG.TypeGraph graph info => graph -> (a, graph)) -> m a 34 | withTypeGraph f = withTypeGraphM (return . f) 35 | withTypeGraphM :: (forall graph . TG.TypeGraph graph info => graph -> m (a, graph)) -> m a 36 | 37 | 38 | useTypeGraph :: HasTG m info => (forall graph . TG.TypeGraph graph info => graph -> a) -> m a 39 | useTypeGraph f = withTypeGraph (\g -> (f g, g)) 40 | 41 | changeTypeGraph :: HasTG m info => (forall graph . TG.TypeGraph graph info => graph -> graph ) -> m () 42 | changeTypeGraph f = withTypeGraph (\g -> ((), f g)) 43 | 44 | changeTypeGraphM :: HasTG m info => (forall graph . TG.TypeGraph graph info => graph -> m graph ) -> m () 45 | changeTypeGraphM f = withTypeGraphM (\g -> (\fg -> ((), fg)) <$> f g) 46 | 47 | -- construct a type graph 48 | 49 | addTermGraph :: (HasTypeGraph m info, Ln.Fresh m) => Tm.VAL -> m VertexId 50 | addTermGraph tp = 51 | do unique <- Ln.fresh $ Ln.s2n "addTermGraph" 52 | --synonyms <- getTypeSynonyms 53 | (vid) <- withTypeGraph 54 | $ \graph -> Ln.runFreshM $ TG.addTermGraph M.empty (Ln.s2n "addTerm") tp graph 55 | 56 | --setUnique newUnique 57 | return vid 58 | 59 | addVertex :: HasTypeGraph m info => VertexId -> VertexInfo -> m () 60 | addVertex vid info = changeTypeGraph (TG.addVertex vid info) 61 | 62 | addEdge :: HasTypeGraph m info => EdgeId -> info -> m () 63 | addEdge edgeId info = changeTypeGraph (TG.addEdge edgeId info) 64 | 65 | addNewEdge :: HasTypeGraph m info => (VertexId, VertexId) -> info -> m () 66 | addNewEdge pair info = do 67 | changeTypeGraph (\gr -> Ln.runFreshM $ TG.addNewEdge pair info gr) 68 | 69 | -- deconstruct a type graph 70 | 71 | deleteEdge :: HasTypeGraph m info => EdgeId -> m () 72 | deleteEdge edgeId = changeTypeGraph (TG.deleteEdge edgeId) 73 | 74 | -- inspect an equivalence group in a type graph 75 | 76 | verticesInGroupOf :: HasTypeGraph m info => VertexId -> m [(VertexId, VertexInfo)] 77 | verticesInGroupOf vid = useTypeGraph (TG.verticesInGroupOf vid) 78 | 79 | childrenInGroupOf :: HasTypeGraph m info => VertexId -> m ([ParentChild], [ParentChild]) 80 | childrenInGroupOf vid = useTypeGraph (TG.childrenInGroupOf vid) 81 | 82 | constantsInGroupOf :: HasTypeGraph m info => VertexId -> m [Constant] 83 | constantsInGroupOf vid = useTypeGraph (TG.constantsInGroupOf vid) 84 | 85 | representativeInGroupOf :: HasTypeGraph m info => VertexId -> m VertexId 86 | representativeInGroupOf vid = useTypeGraph (TG.representativeInGroupOf vid) 87 | 88 | edgesFrom :: HasTypeGraph m info => VertexId -> m [(EdgeId, info)] 89 | edgesFrom vid = useTypeGraph (TG.edgesFrom vid) 90 | 91 | allEdges :: HasTypeGraph m info => m [(EdgeId, info)] 92 | allEdges = useTypeGraph TG.allEdges 93 | 94 | -- query a path in an equivalence group 95 | allPaths :: HasTypeGraph m info => VertexId -> VertexId -> m (TypeGraphPath info) 96 | allPaths v1 v2 = useTypeGraph (TG.allPaths v1 v2) 97 | 98 | allPathsList :: HasTypeGraph m info => VertexId -> [VertexId] -> m (TypeGraphPath info) 99 | allPathsList v1 vs = useTypeGraph (TG.allPathsList v1 vs) 100 | 101 | allPathsListWithout :: HasTypeGraph m info => S.Set VertexId -> VertexId -> [VertexId] -> m (TypeGraphPath info) 102 | allPathsListWithout set v1 vs = useTypeGraph (TG.allPathsListWithout set v1 vs) 103 | 104 | -- substitution and term graph 105 | substituteVariable :: HasTypeGraph m info => Tm.Nom -> m Tm.VAL 106 | substituteVariable i = 107 | do synonyms <- return M.empty 108 | useTypeGraph (TG.substituteVariable synonyms i) 109 | 110 | substituteType :: HasTypeGraph m info => Tm.VAL -> m Tm.VAL 111 | substituteType tp = 112 | do synonyms <- return M.empty 113 | useTypeGraph (TG.substituteType synonyms tp) 114 | 115 | substituteTypeSafe :: HasTypeGraph m info => Tm.VAL -> m (Maybe Tm.VAL) 116 | substituteTypeSafe tp = 117 | do synonyms <- return M.empty 118 | useTypeGraph (TG.substituteTypeSafe synonyms tp) 119 | 120 | makeSubstitution :: HasTypeGraph m info => m [(VertexId, Tm.VAL)] 121 | makeSubstitution = 122 | do synonyms <- return M.empty 123 | useTypeGraph (TG.makeSubstitution synonyms) 124 | 125 | typeFromTermGraph :: HasTypeGraph m info => VertexId -> m Tm.VAL 126 | typeFromTermGraph vid = useTypeGraph (TG.typeFromTermGraph vid) 127 | 128 | -- Extra administration 129 | markAsPossibleError :: HasTypeGraph m info => VertexId -> m () 130 | markAsPossibleError vid = changeTypeGraph (TG.markAsPossibleError vid) 131 | 132 | getMarkedPossibleErrors :: HasTypeGraph m info => m [VertexId] 133 | getMarkedPossibleErrors = useTypeGraph TG.getMarkedPossibleErrors 134 | 135 | unmarkPossibleErrors :: HasTypeGraph m info => m () 136 | unmarkPossibleErrors = changeTypeGraph TG.unmarkPossibleErrors 137 | 138 | --------------------- 139 | ------ EXTRA 140 | 141 | theUnifyTerms :: (Ln.Fresh m, HasTypeGraph m info) => info -> Tm.VAL -> Tm.VAL -> m () 142 | theUnifyTerms info t1 t2 = 143 | do v1 <- addTermGraph t1 144 | v2 <- addTermGraph t2 145 | addNewEdge (v1, v2) info 146 | 147 | makeFixpointSubst = error "TODO fixpointSubst" 148 | 149 | getDot :: HasTypeGraph m info => m String 150 | getDot = useTypeGraph $ TG.toDot 151 | 152 | recordVar :: HasTypeGraph m info => Tm.Nom -> Tm.Param -> m () 153 | recordVar n p = changeTypeGraph $ TG.recordVar n p 154 | 155 | -- makeFixpointSubst :: HasTypeGraph m info => m FixpointSubstitution 156 | -- makeFixpointSubst = 157 | -- do xs <- makeSubstitution 158 | -- let list = [ (i, tp) | (VertexId i, tp) <- xs ] 159 | -- return (FixpointSubstitution (M.fromList list)) 160 | -------------------------------------------------------------------------------- /src/Top/Implementation/TypeGraph/Heuristic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, FlexibleContexts #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | ----------------------------------------------------------------------------- 9 | 10 | module Top.Implementation.TypeGraph.Heuristic where 11 | 12 | import Top.Implementation.TypeGraph.ClassMonadic 13 | import Top.Implementation.TypeGraph.Basics 14 | import Top.Implementation.TypeGraph.Path 15 | import Top.Types 16 | import Top.Solver 17 | import Utils (internalError) 18 | 19 | import qualified PatternUnify.Tm as Tm 20 | 21 | ----------------------------------------------------------------------------- 22 | 23 | type PathHeuristics info = Path (EdgeId, info) -> [Heuristic info] 24 | 25 | newtype Heuristic info = Heuristic (forall m . HasTypeGraph m info => HComponent m info) 26 | data Selector m info 27 | = Selector (String, (EdgeId, info) -> m (Maybe (Int, String, [EdgeId], info))) 28 | | SelectorList (String, [(EdgeId, info)] -> m (Maybe (Int, String, [EdgeId], info))) 29 | 30 | data HComponent m info 31 | = Filter String ([(EdgeId, info)] -> m [(EdgeId, info)]) 32 | | Voting [Selector m info] 33 | 34 | getSelectorName :: (MonadWriter LogEntries m, HasTypeGraph m info) => Selector m info -> String 35 | getSelectorName (Selector (name,_)) = name 36 | getSelectorName (SelectorList (name,_)) = name 37 | 38 | resultsEdgeFilter :: (Eq a, Monad m) => ([a] -> a) -> String -> ((EdgeId,info) -> m a) -> HComponent m info 39 | resultsEdgeFilter selector description function = 40 | Filter description $ \es -> 41 | do tupledList <- let f tuple = 42 | do result <- function tuple 43 | return (result, tuple) 44 | in mapM f es 45 | let maximumResult 46 | | null tupledList = internalError "Top.TypeGraph.Heuristics" "resultsEdgeFilter" "unexpected empty list" 47 | | otherwise = selector (map fst tupledList) 48 | return (map snd (filter ((maximumResult ==) . fst) tupledList)) 49 | 50 | maximalEdgeFilter :: (Ord a, Monad m) => String -> ((EdgeId,info) -> m a) -> HComponent m info 51 | maximalEdgeFilter = resultsEdgeFilter maximum 52 | 53 | minimalEdgeFilter :: (Ord a, Monad m) => String -> ((EdgeId,info) -> m a) -> HComponent m info 54 | minimalEdgeFilter = resultsEdgeFilter minimum 55 | 56 | edgeFilter :: Monad m => String -> ((EdgeId, info) -> m Bool) -> HComponent m info 57 | edgeFilter description function = 58 | Filter description $ \es -> 59 | do xs <- filterM function es 60 | return (if null xs then es else xs) 61 | 62 | 63 | ----------------------------------------------------------------------------- 64 | 65 | doWithoutEdges :: HasTypeGraph m info => [(EdgeId, info)] -> m result -> m result 66 | doWithoutEdges xs computation = 67 | case xs of 68 | [] -> computation 69 | [e] -> doWithoutEdge e computation 70 | e:es -> doWithoutEdge e (doWithoutEdges es computation) 71 | 72 | doWithoutEdge :: HasTypeGraph m info => (EdgeId, info) -> m result -> m result 73 | doWithoutEdge (edge, info) computation = 74 | do -- copy1 <- mapM showGroupOf [0..100] 75 | deleteEdge edge 76 | result <- computation 77 | addEdge edge info 78 | -- copy2 <- mapM showGroupOf [0..100] 79 | -- if copy1 /= copy2 then 80 | -- error ("SAFETY check failed\n\n" ++ head [ x1++x2 | (x1, x2) <- zip copy1 copy2, x1 /= x2]) else 81 | return result 82 | 83 | eqInfo2 :: (EdgeId, info) -> (EdgeId, info) -> Bool 84 | eqInfo2 (EdgeId _ _ b1, _) (EdgeId _ _ b2, _) = b1 == b2 85 | 86 | info2ToEdgeNr :: (EdgeId, info) -> EdgeNr 87 | info2ToEdgeNr (EdgeId _ _ i, _) = i 88 | 89 | ----------------------------------------------------------------------------- 90 | 91 | class HasTwoTypes a where 92 | getTwoTypes :: a -> (Tm.VAL, Tm.VAL) 93 | 94 | getSubstitutedTypes :: (HasTypeGraph m info, HasTwoTypes info) => info -> m (Maybe Tm.VAL, Maybe Tm.VAL) 95 | getSubstitutedTypes info = 96 | do let (t1,t2) = getTwoTypes info 97 | mt1 <- substituteTypeSafe t1 98 | mt2 <- substituteTypeSafe t2 99 | return (mt1, mt2) 100 | -------------------------------------------------------------------------------- /src/Top/Implementation/TypeGraphSubstitution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | ----------------------------------------------------------------------------- 4 | -- | License : GPL 5 | -- 6 | -- Maintainer : helium@cs.uu.nl 7 | -- Stability : provisional 8 | -- Portability : non-portable (requires extensions) 9 | ----------------------------------------------------------------------------- 10 | 11 | module Top.Implementation.TypeGraphSubstitution where 12 | 13 | import Top.Implementation.TypeGraph.ClassMonadic 14 | import Top.Implementation.TypeGraph.Standard 15 | import Top.Implementation.TypeGraph.Heuristic 16 | import Top.Interface.Substitution 17 | import Top.Interface.Basic 18 | import Top.Interface.TypeInference 19 | import Top.Interface.Qualification 20 | import Top.Implementation.TypeGraph.DefaultHeuristics 21 | import Top.Implementation.TypeGraph.ApplyHeuristics 22 | import Top.Monad.Select 23 | import Top.Monad.StateFix 24 | import Top.Solver 25 | import Top.Implementation.General 26 | import Top.Util.Embedding 27 | 28 | ------------------------------------------------------------------------ 29 | -- (I) Algebraic data type 30 | 31 | data TypeGraphState info = TypeGraphState 32 | { typegraph :: StandardTypeGraph info 33 | , heuristics :: PathHeuristics info 34 | } 35 | 36 | ------------------------------------------------------------------------ 37 | -- (II) Instance of SolveState (Empty, Show) 38 | 39 | instance Show info => SolveState (TypeGraphState info) where 40 | stateName _ = "Typegraph substitution state" 41 | 42 | instance Show info => Show (TypeGraphState info) where 43 | show = show . typegraph 44 | 45 | instance Show info => Empty (TypeGraphState info) where 46 | empty = TypeGraphState empty defaultHeuristics 47 | 48 | ------------------------------------------------------------------------ 49 | -- (III) Embeddings 50 | 51 | instance Embedded ClassSubst (TypeGraphState info) (TypeGraphState info) where embedding = idE 52 | instance Embedded ClassSubst (Simple (TypeGraphState info) x m) (TypeGraphState info) where embedding = fromFstSimpleE embedding 53 | 54 | ------------------------------------------------------------------------ 55 | -- (IV) Instance declaration 56 | 57 | instance ( Monad m 58 | , Embedded ClassSubst (s (StateFixT s m)) t 59 | , HasTG (Select t (StateFixT s m)) info 60 | ) => 61 | HasTG (StateFixT s m) info where 62 | 63 | withTypeGraph f = deSubst (withTypeGraph f) 64 | 65 | instance ( MonadState s m 66 | , Embedded ClassSubst s (TypeGraphState info) 67 | ) => 68 | HasTG (Select (TypeGraphState info) m) info where 69 | 70 | withTypeGraph f = 71 | do (a, new) <- gets (f . typegraph) 72 | modify (\tgs -> tgs { typegraph = new }) 73 | return a 74 | 75 | instance ( HasBasic m info 76 | , HasTI m info 77 | , HasQual m info 78 | , HasTG m info 79 | , MonadWriter LogEntries m 80 | , Show info 81 | , MonadState s m 82 | , Embedded ClassSubst s (TypeGraphState info) 83 | ) => 84 | HasSubst (Select (TypeGraphState info) m) info where 85 | 86 | makeSubstConsistent = 87 | do hs <- gets heuristics 88 | select (removeInconsistencies hs) 89 | 90 | unifyTerms a b c = select (theUnifyTerms a b c) 91 | findSubstForVar a = select (substituteVariable a) 92 | fixpointSubst = select makeFixpointSubst 93 | 94 | removeInconsistencies :: HasTypeGraph m info => PathHeuristics info -> m () 95 | removeInconsistencies hs = 96 | do errs <- applyHeuristics hs 97 | mapM_ deleteEdge (concatMap fst errs) 98 | mapM_ (addLabeledError unificationErrorLabel . snd) errs 99 | if null errs 100 | then -- everything is okay: no errors were found. 101 | unmarkPossibleErrors 102 | else -- Bug patch 3 february 2004 103 | -- safety first: check whether *everything* is really removed. 104 | removeInconsistencies hs -------------------------------------------------------------------------------- /src/Top/Implementation/TypeInference.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | -- 9 | -- Additional state information that should be stored in order to perform 10 | -- type inference. 11 | -- 12 | ----------------------------------------------------------------------------- 13 | 14 | module Top.Implementation.TypeInference where 15 | 16 | import Top.Types 17 | import Top.Implementation.General 18 | import Top.Interface.TypeInference 19 | -- import Data.List 20 | import qualified Data.Map as M 21 | import Top.Util.Empty 22 | import Top.Monad.Select 23 | -- import Control.Monad.State 24 | import Utils (internalError) 25 | 26 | ------------------------------------------------------------------------ 27 | -- (I) Algebraic data type 28 | 29 | data TIState info = TIState 30 | { counter :: Int -- ^ A counter for fresh type variables 31 | , synonyms :: OrderedTypeSynonyms -- ^ All known type synonyms 32 | , skolems :: [([Int], info, Tps)] -- ^ List of skolem constants 33 | , schemeMap :: M.Map Int (Scheme Predicates) -- ^ Type scheme map 34 | } 35 | 36 | ------------------------------------------------------------------------ 37 | -- (II) Instance of SolveState (Empty, Show) 38 | 39 | instance Show info => SolveState (TIState info) where 40 | stateName _ = "Type Inference State" 41 | 42 | -- |An empty type inference state. 43 | instance Show info => Empty (TIState info) where 44 | empty = TIState 45 | { counter = 0 46 | , synonyms = noOrderedTypeSynonyms 47 | , skolems = [] 48 | , schemeMap = M.empty 49 | } 50 | 51 | instance Show info => Show (TIState info) where 52 | show s = unlines [ "counter: " ++ show (counter s) 53 | , "skolem constants: " ++ show (skolems s) 54 | , "synonyms: " ++ concat [ t++"; " | t <- M.keys (fst (synonyms s)) ] 55 | , let f (i, x) = " s"++show i++" = "++show x 56 | in unlines $ map f (M.toList $ schemeMap s) 57 | ] 58 | 59 | ------------------------------------------------------------------------ 60 | -- (III) Embeddings 61 | 62 | instance Embedded ClassTI (Simple (TIState info) x m) (TIState info) where embedding = fstSimpleE 63 | 64 | ------------------------------------------------------------------------ 65 | -- (IV) Instance declaration 66 | 67 | instance ( MonadState s m 68 | , Embedded ClassTI s (TIState info) 69 | ) => 70 | HasTI (Select (TIState info) m) info where 71 | 72 | getUnique = gets counter 73 | setUnique i = modify (\x -> x { counter = i }) 74 | 75 | getTypeSynonyms = gets synonyms 76 | setTypeSynonyms xs = modify (\x -> x { synonyms = xs }) 77 | 78 | getSkolems = gets skolems 79 | setSkolems sk = modify (\x -> x { skolems = sk }) 80 | 81 | allTypeSchemes = 82 | gets schemeMap 83 | 84 | getTypeScheme i = 85 | let err = internalError "Top.States.QualifierState" "getTypeScheme" "sigma var not found in map" 86 | in gets (M.findWithDefault err i . schemeMap) 87 | 88 | storeTypeScheme sv scheme = 89 | let f s = s { schemeMap = M.insert sv scheme (schemeMap s) } 90 | in modify f -------------------------------------------------------------------------------- /src/Top/Interface/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | ----------------------------------------------------------------------------- 7 | -- | License : GPL 8 | -- 9 | -- Maintainer : helium@cs.uu.nl 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires extensions) 12 | ----------------------------------------------------------------------------- 13 | 14 | module Top.Interface.Basic where 15 | 16 | import Top.Constraint 17 | import Top.Monad.Select 18 | import Top.Monad.StateFix 19 | import Top.Util.Option 20 | import Utils (internalError) 21 | 22 | ------------------------------------------------------------------------ 23 | -- (I) Class name and (dedicated) deselect function 24 | 25 | data ClassBasic = ClassBasic 26 | 27 | deBasic :: (Embedded ClassBasic (s (StateFixT s m)) (t (StateFixT s m)), Monad m) => SelectFix t (StateFixT s m) a -> StateFixT s m a 28 | deBasic = deselectFixFor ClassBasic 29 | 30 | ------------------------------------------------------------------------ 31 | -- (II) Type class declaration 32 | 33 | class Monad m => HasBasic m info | m -> info where 34 | 35 | -- constraints 36 | pushConstraint :: Constraint m -> m () 37 | pushConstraints :: Constraints m -> m () 38 | popConstraint :: m (Maybe (Constraint m)) 39 | discardConstraints :: m () 40 | -- errors 41 | addLabeledError :: ErrorLabel -> info -> m () 42 | getLabeledErrors :: m [(info, ErrorLabel)] 43 | updateErrorInfo :: (info -> m info) -> m () 44 | -- conditions 45 | addCheck :: String -> m Bool -> m () 46 | getChecks :: m [(m Bool, String)] 47 | -- options 48 | stopAfterFirstError :: OptionAccess m Bool 49 | checkConditions :: OptionAccess m Bool 50 | 51 | -- defaults 52 | pushConstraint c = pushConstraints [c] 53 | pushConstraints = mapM_ pushConstraint 54 | stopAfterFirstError = ignoreOption stopOption 55 | checkConditions = ignoreOption checkOption 56 | 57 | ------------------------------------------------------------------------ 58 | -- (III) Instance for solver monad 59 | 60 | instance ( Monad m 61 | , Embedded ClassBasic (s (StateFixT s m)) (t (StateFixT s m)) 62 | , HasBasic (SelectFix t (StateFixT s m)) info 63 | ) => 64 | HasBasic (StateFixT s m) info where 65 | 66 | -- constraints 67 | pushConstraint = deBasic . pushConstraint . mapConstraint selectFix 68 | pushConstraints = deBasic . pushConstraints . map (mapConstraint selectFix) 69 | popConstraint = deBasic $ liftM (fmap (mapConstraint deBasic)) popConstraint 70 | discardConstraints = deBasic discardConstraints 71 | -- errors 72 | addLabeledError label = deBasic . addLabeledError label 73 | getLabeledErrors = deBasic getLabeledErrors 74 | updateErrorInfo = deBasic . selectFix . updateErrorInfo 75 | -- conditions 76 | addCheck s = deBasic . addCheck s . selectFix 77 | getChecks = deBasic (selectFix getChecks) 78 | -- options 79 | stopAfterFirstError = optionAccessTrans deBasic stopAfterFirstError 80 | checkConditions = optionAccessTrans deBasic checkConditions 81 | 82 | ------------------------------------------------------------------------ 83 | -- (IV) Additional functions 84 | 85 | pushOperation :: HasBasic m info => m () -> m () 86 | pushOperation = pushNamedOperation "operation" 87 | 88 | pushNamedOperation :: HasBasic m info => String -> m () -> m () 89 | pushNamedOperation s = pushConstraint . operation s 90 | 91 | addError :: HasBasic m info => info -> m () 92 | addError = addLabeledError NoErrorLabel 93 | 94 | getErrors :: HasBasic m info => m [info] 95 | getErrors = liftM (map fst) getLabeledErrors 96 | 97 | doChecks :: HasBasic m info => m () 98 | doChecks = 99 | do ms <- getChecks 100 | bs <- filterM (liftM not . fst) ms 101 | unless (null bs) $ 102 | let err = "\n\n The following constraints were violated:\n" 103 | ++ unlines (map ((" - "++) . snd) bs) 104 | in internalError "Top.States.BasicState" "doChecks" err 105 | 106 | startSolving :: HasBasic m info => m () 107 | startSolving = 108 | do mc <- popConstraint 109 | case mc of 110 | Nothing -> 111 | do check <- getOption checkConditions 112 | errs <- getErrors 113 | when (check && null errs) doChecks 114 | Just c -> 115 | do solveConstraint c 116 | addCheck (show c) (checkCondition c) 117 | startSolving 118 | 119 | -- |A datatype to label the errors that are detected. 120 | data ErrorLabel = ErrorLabel String 121 | | NoErrorLabel 122 | deriving (Eq, Ord, Show) 123 | 124 | stopOption, checkOption :: Option Bool 125 | stopOption = option False "Stop solving constraints after the first error" 126 | checkOption = option False "Check constraint satisfaction afterwards" 127 | -------------------------------------------------------------------------------- /src/Top/Interface/Qualification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | ----------------------------------------------------------------------------- 7 | -- | License : GPL 8 | -- 9 | -- Maintainer : helium@cs.uu.nl 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires extensions) 12 | ----------------------------------------------------------------------------- 13 | 14 | module Top.Interface.Qualification where 15 | 16 | import Top.Interface.Substitution 17 | import Top.Monad.Select 18 | import Top.Monad.StateFix 19 | import Top.Types hiding (contextReduction) 20 | {- 21 | ------------------------------------------------------------------------ 22 | -- (I) Class name and (dedicated) deselect function 23 | 24 | data ClassQual = ClassQual 25 | 26 | deQual :: (Embedded ClassQual (s (StateFixT s m)) t, Monad m) => Select t (StateFixT s m) a -> StateFixT s m a 27 | deQual = deselectFor ClassQual 28 | 29 | ------------------------------------------------------------------------ 30 | -- (II) Type class declaration 31 | 32 | 33 | class Monad m => HasQual m info | m -> info where 34 | 35 | -- general 36 | proveQualifier :: info -> Predicate -> m () 37 | assumeQualifier :: info -> Predicate -> m () 38 | changeQualifiers :: (Predicate -> m Predicate) -> m () 39 | 40 | allQualifiers :: m [Predicate] 41 | generalizeWithQualifiers :: Tps -> Tp -> m (Scheme [Predicate]) 42 | 43 | improveQualifiers :: Bool -> m [(info, Tp, Tp)] 44 | improveQualifiersNormal :: m [(info, Tp, Tp)] 45 | improveQualifiersFinal :: m [(info, Tp, Tp)] 46 | simplifyQualifiers :: m () 47 | ambiguousQualifiers :: m () 48 | 49 | -- class environment 50 | setClassEnvironment :: ClassEnvironment -> m () 51 | getClassEnvironment :: m ClassEnvironment 52 | 53 | -- default definitions 54 | generalizeWithQualifiers monos = 55 | return . generalize monos . ([] .=>.) 56 | 57 | improveQualifiers normal = 58 | if normal then improveQualifiersNormal else improveQualifiersFinal 59 | 60 | improveQualifiersNormal = 61 | return [] 62 | 63 | improveQualifiersFinal = 64 | return [] 65 | 66 | simplifyQualifiers = 67 | return () 68 | 69 | ambiguousQualifiers = 70 | return () 71 | 72 | ------------------------------------------------------------------------ 73 | -- (III) Instance for solver monad 74 | 75 | instance ( Monad m 76 | , Embedded ClassQual (s (StateFixT s m)) t 77 | , HasQual (Select t (StateFixT s m)) info 78 | ) => 79 | HasQual (StateFixT s m) info where 80 | 81 | proveQualifier info p = deQual (proveQualifier info p) 82 | assumeQualifier info p = deQual (assumeQualifier info p) 83 | changeQualifiers f = deQual (changeQualifiers (select . f)) 84 | 85 | allQualifiers = deQual allQualifiers 86 | generalizeWithQualifiers monos tp = 87 | deQual (generalizeWithQualifiers monos tp) 88 | 89 | improveQualifiers = deQual . improveQualifiers 90 | improveQualifiersNormal = deQual improveQualifiersNormal 91 | improveQualifiersFinal = deQual improveQualifiersFinal 92 | simplifyQualifiers = deQual simplifyQualifiers 93 | ambiguousQualifiers = deQual ambiguousQualifiers 94 | 95 | setClassEnvironment = deQual . setClassEnvironment 96 | getClassEnvironment = deQual getClassEnvironment 97 | 98 | ------------------------------------------------------------------------ 99 | -- (IV) Additional functions 100 | 101 | proveQualifiers :: HasQual m info => info -> Predicates -> m () 102 | proveQualifiers info = mapM_ (proveQualifier info) 103 | 104 | assumeQualifiers :: HasQual m info => info -> Predicates -> m () 105 | assumeQualifiers info = mapM_ (assumeQualifier info) 106 | 107 | contextReduction :: (HasSubst m info, HasQual m info) => m () 108 | contextReduction = 109 | do makeSubstConsistent 110 | changeQualifiers applySubst 111 | improveQualifiersFix True 112 | simplifyQualifiers 113 | 114 | ambiguities :: (HasSubst m info, HasQual m info) => m () 115 | ambiguities = 116 | do contextReduction 117 | improveQualifiersFix False 118 | ambiguousQualifiers 119 | 120 | improveQualifiersFix :: (HasSubst m info, HasQual m info) => Bool -> m () 121 | improveQualifiersFix normal = 122 | do improvements <- improveQualifiers normal 123 | case improvements of 124 | [] -> return () 125 | _ -> do mapM_ (\(info, t1, t2) -> unifyTerms info t1 t2) improvements 126 | makeSubstConsistent 127 | improveQualifiersFix normal 128 | -} 129 | -------------------------------------------------------------------------------- /src/Top/Interface/Substitution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | ----------------------------------------------------------------------------- 7 | -- | License : GPL 8 | -- 9 | -- Maintainer : helium@cs.uu.nl 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires extensions) 12 | ----------------------------------------------------------------------------- 13 | 14 | module Top.Interface.Substitution where 15 | 16 | import Top.Interface.Basic (ErrorLabel (..)) 17 | import Top.Monad.Select 18 | import Top.Monad.StateFix 19 | import Top.Types 20 | 21 | import qualified PatternUnify.Tm as Tm 22 | 23 | ------------------------------------------------------------------------ 24 | -- (I) Class name and (dedicated) deselect function 25 | 26 | data ClassSubst = ClassSubst 27 | 28 | deSubst :: (Embedded ClassSubst (s (StateFixT s m)) t, Monad m) => Select t (StateFixT s m) a -> StateFixT s m a 29 | deSubst = deselectFor ClassSubst 30 | 31 | ------------------------------------------------------------------------ 32 | -- (II) Type class declaration 33 | 34 | class Monad m => HasSubst m info | m -> info where 35 | 36 | -- |Make the state consistent. Only relevant for substitution states that 37 | -- can be inconsistent (for instance, the type graph substitution state). 38 | makeSubstConsistent :: m () 39 | 40 | -- |Unify two terms. Supply additional information for this unification. 41 | unifyTerms :: info -> Tm.VAL -> Tm.VAL -> m () 42 | 43 | -- |Lookup the value of a type variable in the substitution 44 | findSubstForVar :: Tm.Nom -> m Tm.VAL 45 | 46 | -- |Return a fixpoint substitution. 47 | fixpointSubst :: m FixpointSubstitution 48 | 49 | ------------------------------------------------------------------------ 50 | -- (III) Instance for solver monad 51 | 52 | instance ( Monad m 53 | , Embedded ClassSubst (s (StateFixT s m)) t 54 | , HasSubst (Select t (StateFixT s m)) info 55 | ) => 56 | HasSubst (StateFixT s m) info where 57 | 58 | makeSubstConsistent = deSubst makeSubstConsistent 59 | unifyTerms info t1 t2 = deSubst (unifyTerms info t1 t2) 60 | findSubstForVar = deSubst . findSubstForVar 61 | fixpointSubst = deSubst fixpointSubst 62 | 63 | ------------------------------------------------------------------------ 64 | -- (IV) Additional functions 65 | 66 | unificationErrorLabel :: ErrorLabel 67 | unificationErrorLabel = ErrorLabel "unification" 68 | 69 | -- |Apply the substitution to a value that contains type variables (a 70 | -- member of the Substitutable type class). 71 | applySubst :: (Substitutable a, HasSubst m info) => a -> m a 72 | applySubst a = 73 | do let var = ftv a 74 | tps <- mapM findSubstForVar var 75 | let sub = listToSubstitution (zip var tps) 76 | return (sub |-> a) 77 | -------------------------------------------------------------------------------- /src/Top/Monad/Select.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverlappingInstances, KindSignatures, 2 | FunctionalDependencies, FlexibleInstances #-} 3 | ----------------------------------------------------------------------------- 4 | -- | License : GPL 5 | -- 6 | -- Maintainer : helium@cs.uu.nl 7 | -- Stability : provisional 8 | -- Portability : non-portable (requires extensions) 9 | ----------------------------------------------------------------------------- 10 | 11 | module Top.Monad.Select 12 | ( module Top.Monad.Select 13 | , module Control.Monad.State 14 | ) where 15 | 16 | import Top.Util.Embedding 17 | import Control.Monad.State 18 | 19 | -------------------------------------------------------- 20 | -- Select Monad 21 | 22 | newtype Select t m a = Select (m a) 23 | 24 | -- To satisfy the 7.10.x proposal: 25 | instance Monad m => Functor (Select s m) where 26 | fmap = liftM 27 | 28 | instance Monad m => Applicative (Select s m) where 29 | pure = Select . return 30 | (<*>) = ap 31 | 32 | -- Back to real code: 33 | instance Monad m => Monad (Select t m) where 34 | return = pure 35 | Select f >>= g = Select (do x <- f 36 | let Select h = g x 37 | h) 38 | 39 | instance (MonadState s m, Embedded label s t) => MonadState t (Select t m) where 40 | get = Select (gets (getE embedding )) 41 | put i = Select (modify (setE embedding i)) 42 | 43 | instance MonadTrans (Select t) where 44 | lift = select 45 | 46 | select :: m a -> Select t m a 47 | select = Select 48 | 49 | -------------------------------------------------------- 50 | -- SelectFix Monad 51 | 52 | data SelectFix (t :: (* -> *) -> *) (m :: * -> *) a = SelectFix (m a) 53 | 54 | -- To satisfy the 7.10.x proposal: 55 | instance Monad m => Functor (SelectFix t m) where 56 | fmap = liftM 57 | 58 | instance Monad m => Applicative (SelectFix t m) where 59 | pure = SelectFix . return 60 | (<*>) = ap 61 | 62 | -- Back to real code: 63 | instance Monad m => Monad (SelectFix t m) where 64 | return = pure 65 | SelectFix f >>= g = SelectFix (do x <- f 66 | let SelectFix h = g x 67 | h) 68 | 69 | instance (MonadState s m, Embedded label s (t m)) => MonadState (t m) (SelectFix t m) where 70 | get = SelectFix (gets (getE embedding )) 71 | put i = SelectFix (modify (setE embedding i)) 72 | 73 | instance MonadTrans (SelectFix t) where 74 | lift = selectFix 75 | 76 | selectFix :: m a -> SelectFix t m a 77 | selectFix = SelectFix 78 | 79 | -------------------------------------------------------- 80 | -- Class Embedded 81 | 82 | class Embedded label s t | label s -> t, t -> label where 83 | embedding :: Embedding s t 84 | 85 | instance Embedded c s2 t => Embedded c (s1, s2) t where 86 | embedding = composeE sndE embedding 87 | 88 | -------------------------------------------------------- 89 | -- deselect functions for Select Monad 90 | 91 | deselect :: Select t m a -> m a 92 | deselect (Select m) = m 93 | 94 | deselectFor :: (Embedded label s t, MonadState s m) => label -> Select t m a -> m a 95 | deselectFor _ = deselect 96 | 97 | -------------------------------------------------------- 98 | -- deselect functions for SelectFix Monad 99 | 100 | deselectFix :: SelectFix t m a -> m a 101 | deselectFix (SelectFix m) = m 102 | 103 | deselectFixFor :: (Embedded label s (t m), MonadState s m) => label -> SelectFix t m a -> m a 104 | deselectFixFor _ = deselectFix -------------------------------------------------------------------------------- /src/Top/Monad/StateFix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | ----------------------------------------------------------------------------- 9 | 10 | module Top.Monad.StateFix 11 | ( module Top.Monad.StateFix 12 | , module Control.Monad.State 13 | ) where 14 | 15 | import Control.Monad.State 16 | import Control.Monad.Identity 17 | import Control.Monad.Writer 18 | 19 | type StateFix s = StateFixT s Identity 20 | 21 | data StateFixT s m a = Fix { unFix :: StateT (s (StateFixT s m)) m a } 22 | 23 | -- To satisfy the 7.10.x proposal: 24 | instance Monad m => Functor (StateFixT s m) where 25 | fmap = liftM 26 | 27 | instance Monad m => Applicative (StateFixT s m) where 28 | pure = Fix . return 29 | (<*>) = ap 30 | 31 | -- Back to real code: 32 | instance Monad m => Monad (StateFixT s m) where 33 | return = pure 34 | m >>= f = Fix (unFix m >>= unFix . f) 35 | 36 | instance Monad m => MonadState (s (StateFixT s m)) (StateFixT s m) where 37 | get = Fix get 38 | put = Fix . put 39 | 40 | instance MonadTrans (StateFixT s) where 41 | lift = Fix . lift 42 | 43 | instance MonadWriter w m => MonadWriter w (StateFixT s m) where 44 | tell = lift . tell 45 | listen = Fix . listen . unFix 46 | pass = Fix . pass . unFix 47 | 48 | -- 49 | 50 | runStateFixT :: StateFixT s m a -> s (StateFixT s m) -> m (a, s (StateFixT s m)) 51 | runStateFixT = runStateT . unFix 52 | 53 | evalStateFixT :: Monad m => StateFixT s m a -> s (StateFixT s m) -> m a 54 | evalStateFixT = evalStateT . unFix 55 | 56 | execStateFixT :: Monad m => StateFixT s m a -> s (StateFixT s m) -> m (s (StateFixT s m)) 57 | execStateFixT = execStateT . unFix 58 | 59 | -- 60 | 61 | runStateFix :: StateFix s a -> s (StateFix s) -> (a, s (StateFix s)) 62 | runStateFix m = runIdentity . runStateFixT m 63 | 64 | evalStateFix :: StateFix s a -> s (StateFix s) -> a 65 | evalStateFix m = runIdentity . evalStateFixT m 66 | 67 | execStateFix :: StateFix s a -> s (StateFix s) -> s (StateFix s) 68 | execStateFix m = runIdentity . execStateFixT m -------------------------------------------------------------------------------- /src/Top/Ordering/Tree.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | ----------------------------------------------------------------------------- 8 | 9 | module Top.Ordering.Tree where 10 | 11 | import Top.Ordering.TreeWalk 12 | import Data.List (partition, intersperse) 13 | import qualified Data.Map as M 14 | import qualified Data.Set as S 15 | 16 | type Trees a = [Tree a] 17 | data Tree a = Node (Trees a) 18 | | AddList Direction [a] (Tree a) 19 | | StrictOrder (Tree a) (Tree a) 20 | | Spread Direction [a] (Tree a) 21 | | Receive Int 22 | | Phase Int [a] 23 | | Chunk Int (Tree a) 24 | deriving Show 25 | 26 | emptyTree :: Tree a 27 | unitTree :: a -> Tree a 28 | listTree :: [a] -> Tree a 29 | binTree :: Tree a -> Tree a -> Tree a 30 | 31 | emptyTree = Node [] 32 | unitTree c = listTree [c] 33 | listTree cs = cs .>. emptyTree 34 | binTree a b = Node [a, b] 35 | 36 | infixr 8 .>. , .>>. , .<. , .<<. 37 | 38 | (.>.), (.>>.), (.<.), (.<<.) :: [a] -> Tree a -> Tree a 39 | (.>.) = makeTreeHelper AddList Down 40 | (.>>.) = makeTreeHelper Spread Down 41 | (.<.) = makeTreeHelper AddList Up 42 | (.<<.) = makeTreeHelper Spread Up 43 | 44 | -- prevents adding an empty list 45 | makeTreeHelper constructor direction xs tree 46 | | null xs = tree 47 | | otherwise = constructor direction xs tree 48 | 49 | ------------------------------------------------------------------------ 50 | 51 | data Direction = Up | Down deriving (Eq, Show) 52 | type Spreaded a = M.Map Int [a] 53 | type Phased a = M.Map Int (List a) 54 | 55 | flattenTree :: TreeWalk -> Tree a -> [a] 56 | flattenTree (TreeWalk treewalk) theTree = 57 | strictRec theTree [] 58 | 59 | where 60 | rec :: List a -> -- downward constraints 61 | Tree a -> -- the tree to flatten 62 | ( List a -- the result 63 | , List a -- upward constraints 64 | ) 65 | rec down tree = 66 | case tree of 67 | 68 | Node trees -> 69 | let tuples = map (rec id) trees 70 | in (treewalk down tuples, id) 71 | 72 | Chunk _ t -> 73 | rec down t 74 | 75 | AddList Up as t -> 76 | let (result, up) = rec down t 77 | in (result, (as++) . up) 78 | 79 | AddList Down as t -> 80 | rec ((as++) . down) t 81 | 82 | StrictOrder left right -> 83 | let left_result = strictRec left 84 | right_result = strictRec right 85 | in (treewalk down [(left_result . right_result, id)], id) 86 | 87 | Spread direction as t -> 88 | rec down (AddList direction as t) 89 | 90 | Receive _ -> 91 | rec down emptyTree 92 | 93 | Phase _ as -> 94 | rec down (listTree as) 95 | 96 | strictRec :: Tree a -> -- the tree to flatten 97 | List a -- the result 98 | strictRec tree = 99 | let (result, up) = rec id tree 100 | in treewalk id [(result, up)] 101 | 102 | spreadTree :: (a -> Maybe Int) -> Tree a -> Tree a 103 | spreadTree spreadFunction = fst . rec M.empty 104 | where 105 | rec fm tree = 106 | case tree of 107 | 108 | Node trees -> 109 | let (trees', sets) = unzip (map (rec fm) trees) 110 | in (Node trees', S.unions sets) 111 | 112 | Chunk cnr t -> 113 | let (tree', set) = rec fm t 114 | in (Chunk cnr tree', set) 115 | 116 | AddList direction as t -> 117 | let (tree', set) = rec fm t 118 | in (AddList direction as tree', set) 119 | 120 | StrictOrder left right -> 121 | let (left' , set1) = rec fm left 122 | (right', set2) = rec fm right 123 | in (StrictOrder left' right', set1 `S.union` set2) 124 | 125 | Spread direction as t -> 126 | let (tree', set) = rec fmNew t 127 | fmNew = M.unionWith (++) fm (M.fromList [ (i, [x]) | x <- doSpread, let Just i = spreadFunction x ]) 128 | (doSpread, noSpread) = 129 | partition (maybe False (`S.member` set) . spreadFunction) as 130 | in (Spread direction noSpread tree', set) 131 | 132 | Receive i -> 133 | let t = maybe emptyTree listTree (M.lookup i fm) 134 | in (t, S.singleton i) 135 | 136 | Phase _ _ -> 137 | (tree, S.empty) 138 | 139 | phaseTree :: a -> Tree a -> Tree a 140 | phaseTree a = strictRec 141 | 142 | where 143 | rec tree = 144 | case tree of 145 | 146 | Node trees -> 147 | let (trees', phasesList) = unzip (map rec trees) 148 | phases = foldr (M.unionWith (.)) M.empty phasesList 149 | in (Node trees', phases) 150 | 151 | Chunk cnr t -> 152 | let (tree', phases) = rec t 153 | in (Chunk cnr tree', phases) 154 | 155 | AddList dir as t -> 156 | let (tree', phases) = rec t 157 | in (AddList dir as tree', phases) 158 | 159 | StrictOrder left right -> 160 | let left' = strictRec left 161 | right' = strictRec right 162 | in (StrictOrder left' right', M.empty) 163 | 164 | Spread dir as t -> 165 | let (tree', phases) = rec t 166 | in (Spread dir as tree', phases) 167 | 168 | Receive _ -> 169 | (tree, M.empty) 170 | 171 | Phase i as -> 172 | (emptyTree, M.singleton i (as++)) 173 | 174 | strictRec tree = 175 | let (tree', phases) = rec tree 176 | f list = listTree (list []) 177 | in foldr1 StrictOrder (intersperse (unitTree a) (M.elems (M.insertWith binTree 5 tree' (M.map f phases)))) 178 | 179 | chunkTree :: Tree a -> [(Int, Tree a)] 180 | chunkTree theTree = 181 | let (ts, chunks) = rec theTree 182 | in (-1, ts) : chunks 183 | 184 | where 185 | rec tree = 186 | case tree of 187 | 188 | Node trees -> 189 | let (ts, chunks) = unzip (map rec trees) 190 | in (Node ts, concat chunks) 191 | 192 | -- This chunk should be solved later then the inner chunks. 193 | -- Therefore, the new chunk is appended 194 | Chunk cnr t -> 195 | let (ts, chunks) = rec t 196 | in (emptyTree, chunks ++ [(cnr, ts)]) 197 | 198 | AddList direction as t -> 199 | let (ts, chunks) = rec t 200 | in (AddList direction as ts, chunks) 201 | 202 | StrictOrder left right -> 203 | let (ts1, chunks1) = rec left 204 | (ts2, chunks2) = rec right 205 | in (StrictOrder ts1 ts2, chunks1 ++ chunks2) 206 | 207 | Spread direction as t -> 208 | let (ts, chunks) = rec t 209 | in (Spread direction as ts, chunks) 210 | 211 | _ -> (tree, []) 212 | 213 | instance Functor Tree where 214 | fmap f tree = 215 | case tree of 216 | Node ts -> Node (map (fmap f) ts) 217 | AddList d as t -> AddList d (map f as) (fmap f t) 218 | StrictOrder t1 t2 -> StrictOrder (fmap f t1) (fmap f t2) 219 | Spread d as t -> Spread d (map f as) (fmap f t) 220 | Receive i -> Receive i 221 | Phase i as -> Phase i (map f as) 222 | Chunk i t -> Chunk i (fmap f t) 223 | -------------------------------------------------------------------------------- /src/Top/Ordering/TreeWalk.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | ----------------------------------------------------------------------------- 9 | 10 | module Top.Ordering.TreeWalk where 11 | 12 | newtype TreeWalk = TreeWalk (forall a . List a -> [(List a, List a)] -> List a) 13 | 14 | topDownTreeWalk :: TreeWalk 15 | topDownTreeWalk = TreeWalk (\top cs -> top . children (unzip cs)) 16 | where children (fs,gs) = concatList gs . concatList fs 17 | 18 | bottomUpTreeWalk :: TreeWalk 19 | bottomUpTreeWalk = TreeWalk (\top cs -> children (unzip cs) . top) 20 | where children (fs,gs) = concatList fs . concatList gs 21 | 22 | inorderTopFirstPreTreeWalk :: TreeWalk 23 | inorderTopFirstPreTreeWalk = TreeWalk (\top cs -> top . children cs) 24 | where children = concatList . map (\(f,g) -> g . f) 25 | 26 | inorderTopLastPreTreeWalk :: TreeWalk 27 | inorderTopLastPreTreeWalk = TreeWalk (\top cs -> children cs . top) 28 | where children = concatList . map (\(f,g) -> g . f) 29 | 30 | inorderTopFirstPostTreeWalk :: TreeWalk 31 | inorderTopFirstPostTreeWalk = TreeWalk (\top cs -> top . children cs) 32 | where children = concatList . map (uncurry (.)) 33 | 34 | inorderTopLastPostTreeWalk :: TreeWalk 35 | inorderTopLastPostTreeWalk = TreeWalk (\top cs -> children cs . top) 36 | where children = concatList . map (uncurry (.)) 37 | 38 | reverseTreeWalk :: TreeWalk -> TreeWalk 39 | reverseTreeWalk (TreeWalk f) = TreeWalk (\top cs -> f top (reverse cs)) 40 | 41 | ------------------------------------------------------------------- 42 | 43 | type List a = [a] -> [a] 44 | 45 | concatList :: [List a] -> List a 46 | concatList = foldr (.) id 47 | -------------------------------------------------------------------------------- /src/Top/Solver.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | ----------------------------------------------------------------------------- 9 | 10 | module Top.Solver 11 | ( module Top.Solver 12 | , module Control.Monad.Writer 13 | ) where 14 | 15 | import Top.Types 16 | import Top.Interface.Basic 17 | import Top.Interface.TypeInference 18 | import Top.Interface.Substitution 19 | import Top.Interface.Qualification 20 | import Top.Implementation.General 21 | import Top.Util.Option 22 | import Top.Monad.StateFix 23 | import Top.Constraint 24 | import qualified Data.Map as M 25 | import Top.Constraint.Information 26 | import Control.Monad.Writer 27 | import qualified Unbound.Generics.LocallyNameless as Ln 28 | import qualified PatternUnify.Tm as Tm 29 | 30 | data ConstraintSolver constraint info = ConstraintSolver (SolveOptions -> [constraint] -> (SolveResult info, LogEntries)) 31 | 32 | makeConstraintSolver :: (Empty (f () (BasicMonad f))) => 33 | (SolveOptions -> [constraint] -> BasicMonad f (SolveResult info)) 34 | -> ConstraintSolver constraint info 35 | makeConstraintSolver f = ConstraintSolver (\options -> evalBasicMonad . f options) 36 | 37 | solve :: SolveOptions -> [constraint] -> ConstraintSolver constraint info -> (SolveResult info, LogEntries) 38 | solve options constraints (ConstraintSolver f) = f options constraints 39 | 40 | --- 41 | 42 | onlySolveConstraints :: 43 | ( -- HasTI m info 44 | HasBasic m info 45 | , HasSubst m info 46 | --, HasQual m info 47 | --, TypeConstraintInfo info 48 | , Solvable constraint m 49 | , MonadState s m 50 | , SolveState s 51 | , MonadWriter LogEntries m 52 | ) => 53 | [constraint] -> m () 54 | 55 | onlySolveConstraints cs = 56 | do pushConstraints (liftConstraints cs) 57 | logState 58 | startSolving 59 | -- makeConsistent 60 | -- checkSkolems 61 | -- ambiguities 62 | logState 63 | 64 | solveConstraints :: 65 | ( --HasTI m info 66 | HasBasic m info 67 | , HasSubst m info 68 | -- , HasQual m info 69 | -- , TypeConstraintInfo info 70 | , Solvable constraint m 71 | , MonadState s m 72 | , SolveState s 73 | , MonadWriter LogEntries m 74 | , Ln.Fresh m 75 | ) => 76 | SolveOptions -> 77 | [constraint] -> 78 | m (SolveResult info) 79 | 80 | solveConstraints options cs = 81 | do initialize cs options 82 | onlySolveConstraints cs 83 | solveResult 84 | 85 | solveResult :: 86 | ( HasBasic m info 87 | --, HasTI m info 88 | , HasSubst m info 89 | , Ln.Fresh m 90 | -- , HasQual m info 91 | -- , TypeConstraintInfo info 92 | ) => 93 | m (SolveResult info) 94 | solveResult = 95 | do uniqueAtEnd <- Ln.fresh $ Ln.s2n "uniqueAtEnd" 96 | errs <- getLabeledErrors 97 | --qs <- allQualifiers 98 | sub <- fixpointSubst 99 | --ts <- allTypeSchemes 100 | return (SolveResult uniqueAtEnd sub {-ts qs-} errs) 101 | 102 | ---------------------------------------------------------------------- 103 | -- Solve type constraints 104 | 105 | data SolveResult info = 106 | SolveResult { uniqueFromResult :: Tm.Nom 107 | , substitutionFromResult :: FixpointSubstitution 108 | --, typeschemesFromResult :: M.Map Int (Scheme Predicates) 109 | --, qualifiersFromResult :: Predicates 110 | , errorsFromResult :: [(info, ErrorLabel)] 111 | } 112 | 113 | instance Empty (SolveResult info) where 114 | empty = emptyResult $ error "Empty inst" 115 | 116 | emptyResult :: Tm.Nom -> SolveResult info 117 | emptyResult unique = SolveResult unique emptyFPS {-M.empty empty-} [] 118 | 119 | combineResults :: SolveResult info -> SolveResult info -> SolveResult info 120 | combineResults (SolveResult _ s1 {-ts1 qs1-} er1) (SolveResult unique s2 {-ts2 qs2-} er2) = 121 | SolveResult unique (disjointFPS s1 s2) {-(ts1 `M.union` ts2) (qs1 ++ qs2)-} (er1++er2) 122 | 123 | -------------------------------------------------------------------------------- 124 | 125 | data SolveOptions = SolveOptions_ 126 | { 127 | -- initial values 128 | uniqueCounter :: Int 129 | , typeSynonyms :: Tm.Subs 130 | --, classEnvironment :: ClassEnvironment 131 | 132 | -- optional settings 133 | , setStopAfterFirstError :: Bool -- see Basic 134 | , setCheckConditions :: Bool -- see Basic 135 | } 136 | 137 | solveOptions :: SolveOptions 138 | solveOptions = SolveOptions_ 139 | { uniqueCounter = -1 140 | , typeSynonyms = (error "noOrdered") --noOrderedTypeSynonyms 141 | --, classEnvironment = standardClasses 142 | , setStopAfterFirstError = currentValue stopOption 143 | , setCheckConditions = currentValue checkOption 144 | } 145 | 146 | initialize :: (HasBasic m info, {-HasQual m info, HasTI m info,-} Substitutable a) => a -> SolveOptions -> m () 147 | initialize cs options = 148 | do --setUnique unique 149 | --setTypeSynonyms (typeSynonyms options) 150 | --setClassEnvironment (classEnvironment options) 151 | setOption stopAfterFirstError (setStopAfterFirstError options) 152 | setOption checkConditions (setCheckConditions options) 153 | -- where 154 | -- unique 155 | -- | uniqueCounter options < 0 = 1 + maximum (-1 : ftv cs) 156 | -- | otherwise = uniqueCounter options 157 | 158 | ---------------------- 159 | -- Basic Monad 160 | 161 | type BasicMonad f = StateFixT (f ()) (Writer LogEntries) 162 | 163 | newtype LogEntries = LogEntries ([LogEntry] -> [LogEntry]) 164 | data LogEntry = LogEntry { priority :: Int, msg :: String } 165 | 166 | noLogEntries :: LogEntries 167 | noLogEntries = LogEntries id 168 | 169 | singleEntry :: Int -> String -> LogEntries 170 | singleEntry i s = LogEntries (LogEntry i s:) 171 | 172 | evalBasicMonad :: Empty (f () (BasicMonad f)) => BasicMonad f a -> (a, LogEntries) 173 | evalBasicMonad = runWriter . flip evalStateFixT empty 174 | 175 | instance Monoid LogEntries where 176 | mempty = LogEntries id 177 | mappend (LogEntries f) (LogEntries g) = LogEntries (f . g) 178 | 179 | instance Show LogEntry where 180 | show = msg 181 | 182 | instance Show LogEntries where 183 | show (LogEntries f) = unlines (map show (f [])) 184 | 185 | logMsg :: MonadWriter LogEntries m => String -> m () 186 | logMsg = logMsgPrio 5 187 | 188 | logMsgPrio :: MonadWriter LogEntries m => Int -> String -> m () 189 | logMsgPrio i s = 190 | let entry = LogEntry { priority = i, msg = s } 191 | in tell (LogEntries (entry:)) 192 | 193 | -- |Print the current state and add this as a debug message. 194 | logState :: (MonadState s m, SolveState s, MonadWriter LogEntries m) => m () 195 | logState = 196 | do xs <- allStates 197 | ys <- allOptions 198 | let hline = replicate 80 '-' 199 | options = "Solver options:\n" ++ indent (unlines ys) 200 | f i (name,s) = show i ++ ". " ++ name ++ "\n" ++ indent s 201 | indent = unlines . map (" "++) . lines 202 | logMsg (unlines $ hline : options : zipWith f [1::Int ..] xs ++ [hline]) 203 | -------------------------------------------------------------------------------- /src/Top/Solver/Greedy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | ----------------------------------------------------------------------------- 9 | 10 | module Top.Solver.Greedy where 11 | 12 | import Top.Implementation.General 13 | import Top.Implementation.Basic 14 | import Top.Implementation.TypeInference 15 | import Top.Implementation.FastSubstitution 16 | import Top.Implementation.SimpleSubstitution 17 | import Top.Implementation.Overloading 18 | import Top.Solver 19 | import Top.Constraint 20 | import Top.Constraint.Information 21 | -- for testing only 22 | -- import Top.Types 23 | -- import Top.Constraint.Equality 24 | 25 | type Greedy info = BasicMonad (GreedyS info) 26 | type GreedyS info = And ( Fix (BasicState info) ) 27 | ( And ( Simple (TIState info) ) 28 | ( And ( Simple (GreedyState info) ) 29 | ( Simple (OverloadingState info) ) 30 | ) 31 | ) 32 | 33 | solveGreedy :: (Solvable constraint (Greedy info), TypeConstraintInfo info) => 34 | SolveOptions -> [constraint] -> Greedy info (SolveResult info) 35 | solveGreedy = solveConstraints 36 | 37 | greedyConstraintSolver :: (TypeConstraintInfo info, Solvable constraint (Greedy info)) => ConstraintSolver constraint info 38 | greedyConstraintSolver = makeConstraintSolver solveGreedy 39 | 40 | -------------------------------- 41 | 42 | type GreedySimple info = BasicMonad (GreedySimpleS info) 43 | type GreedySimpleS info = And ( Fix (BasicState info) ) 44 | ( And ( Simple (TIState info) ) 45 | ( And ( Simple (SimpleState info) ) 46 | ( Simple (OverloadingState info) ) 47 | ) 48 | ) 49 | 50 | solveSimple :: (Solvable constraint (GreedySimple info), TypeConstraintInfo info) => 51 | SolveOptions -> [constraint] -> GreedySimple info (SolveResult info) 52 | solveSimple = solveConstraints 53 | 54 | greedySimpleConstraintSolver :: (TypeConstraintInfo info, Solvable constraint (GreedySimple info)) => ConstraintSolver constraint info 55 | greedySimpleConstraintSolver = makeConstraintSolver solveSimple 56 | 57 | -------------------------------- 58 | {- 59 | cs :: [EqualityConstraint String] 60 | cs = [ TVar 0 .==. (TVar 1 .->. TVar 1) $ "a" 61 | , TVar 0 .==. (TVar 2 .->. TVar 3) $ "b" 62 | , TVar 2 .==. intType $ "c" 63 | , TVar 3 .==. boolType $ "d" 64 | ] 65 | 66 | test = let (a, b) = solve (solveOptions {uniqueCounter = 4}) cs greedyConstraintSolver 67 | in (b, errorsFromResult a) 68 | 69 | test2 = let (a, b) = solve (solveOptions {uniqueCounter = 4}) cs greedySimpleConstraintSolver 70 | in (b, errorsFromResult a) -} -------------------------------------------------------------------------------- /src/Top/Solver/PartitionCombinator.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | ----------------------------------------------------------------------------- 8 | 9 | module Top.Solver.PartitionCombinator where 10 | 11 | import Top.Types 12 | import Top.Solver 13 | import Top.Ordering.Tree 14 | import qualified Data.Map as M 15 | 16 | type Chunks constraint = [Chunk constraint] 17 | type Chunk constraint = (ChunkID, Tree constraint) 18 | type ChunkID = Int 19 | 20 | solveChunkConstraints :: 21 | (M.Map Int (Scheme Predicates) -> constraint -> constraint) -> -- function to update the type scheme variables 22 | ConstraintSolver constraint info -> -- constraint solver to solve the constraints in a chunk 23 | (Tree constraint -> [constraint]) -> -- function to flatten the constraint tree 24 | Chunks constraint -> ConstraintSolver constraint info 25 | 26 | solveChunkConstraints update (ConstraintSolver f) flattening chunks = 27 | ConstraintSolver (\os _ -> 28 | let rec options [] = (emptyResult (uniqueCounter options), noLogEntries) 29 | rec options ((_, tree) : rest) = 30 | let constraintList = flattening tree 31 | (result, entries) 32 | | null constraintList = 33 | (emptyResult (uniqueCounter options), noLogEntries) 34 | | otherwise = 35 | f options constraintList 36 | newOption = options { uniqueCounter = uniqueFromResult result } 37 | schemeMap = typeschemesFromResult result 38 | newRest = [ (chunkID, fmap (update schemeMap) t) | (chunkID, t) <- rest ] 39 | (resultRec, entriesRec) = rec newOption newRest 40 | in (result `combineResults` resultRec, entries `mappend` entriesRec) 41 | in rec os chunks) -------------------------------------------------------------------------------- /src/Top/Solver/SwitchCombinator.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | ----------------------------------------------------------------------------- 8 | 9 | module Top.Solver.SwitchCombinator where 10 | 11 | import Top.Interface.Basic 12 | import Top.Solver 13 | 14 | -- |The first solver is used to solve the constraint set. If this fails (at least one 15 | -- error is returned), then the second solver takes over. 16 | (|>>|) :: ConstraintSolver constraint info -> ConstraintSolver constraint info -> ConstraintSolver constraint info 17 | ConstraintSolver f |>>| ConstraintSolver g = ConstraintSolver $ \options constraints -> 18 | let (result1, logs1) = f options constraints 19 | (result2, logs2) = g options constraints 20 | p (_, ErrorLabel s) = s /= "ambiguous predicate" -- temporary* 21 | p _ = True 22 | switchLog = singleEntry 5 "CombinationSolver: Switching to second solver" 23 | in if not (any p (errorsFromResult result1)) 24 | then (result1, logs1) 25 | else (result2, logs1 `mappend` switchLog `mappend` logs2) 26 | 27 | -- * For now, ignore the ambiguous predicate messages that are returned. They are not shown anyway. 28 | -- These error messages are returned because of the mismatch between the constraints that are generated 29 | -- by the Helium compiler, and the constraints as they are in the Top constraint solver. -------------------------------------------------------------------------------- /src/Top/Solver/TypeGraph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, FlexibleContexts #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | ----------------------------------------------------------------------------- 9 | 10 | module Top.Solver.TypeGraph where 11 | 12 | import Top.Solver 13 | import Top.Constraint 14 | import Top.Constraint.Information 15 | import Top.Implementation.General 16 | import Top.Implementation.Basic 17 | import Top.Implementation.Overloading 18 | import Top.Implementation.TypeInference 19 | import Top.Implementation.TypeGraphSubstitution 20 | import Top.Implementation.TypeGraph.Heuristic 21 | import Top.Monad.Select 22 | 23 | type TG info = BasicMonad (TGS info) 24 | type TGS info = And ( Fix (BasicState info) ) 25 | ( And ( Simple (TIState info) ) 26 | ( And ( Simple (TypeGraphState info) ) 27 | ( Simple (OverloadingState info) ) 28 | ) 29 | ) 30 | 31 | solveTypeGraph :: (Solvable constraint (TG info), TypeConstraintInfo info) 32 | => TG info () -> SolveOptions -> [constraint] -> TG info (SolveResult info) 33 | solveTypeGraph m options cs = 34 | do initialize cs options >> m 35 | onlySolveConstraints cs 36 | solveResult 37 | 38 | typegraphConstraintSolver :: (TypeConstraintInfo info, Solvable constraint (TG info)) 39 | => PathHeuristics info -> ConstraintSolver constraint info 40 | typegraphConstraintSolver hs = 41 | let setHeuristics = deselect (modify (\tgs -> tgs { heuristics = hs })) 42 | in makeConstraintSolver (solveTypeGraph setHeuristics) 43 | 44 | typegraphConstraintSolverDefault :: (TypeConstraintInfo info, Solvable constraint (TG info)) 45 | => ConstraintSolver constraint info 46 | typegraphConstraintSolverDefault = 47 | makeConstraintSolver (solveTypeGraph (return ())) 48 | 49 | --- 50 | {- 51 | cs = [ TVar 0 .==. (TVar 1 .->. TVar 1) $ "a" 52 | , TVar 0 .==. (TVar 2 .->. TVar 3) $ "b" 53 | , TVar 2 .==. intType $ "c" 54 | , TVar 3 .==. boolType $ "d" 55 | ] 56 | 57 | test = let (a, b) = solve (solveOptions {uniqueCounter = 4}) cs typegraphConstraintSolverDefault 58 | in (b, errorsFromResult a) -} -------------------------------------------------------------------------------- /src/Top/Types.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | -- 8 | -- A collection of type utilities. 9 | -- 10 | ----------------------------------------------------------------------------- 11 | 12 | module Top.Types (module Export) where 13 | 14 | --import Top.Types.Primitive as Export 15 | import Top.Types.Classes as Export 16 | import Top.Types.Kinds as Export 17 | import Top.Types.Qualification as Export 18 | import Top.Types.Quantification as Export 19 | import Top.Types.Schemes as Export 20 | import Top.Types.Substitution as Export 21 | import Top.Types.Synonym as Export 22 | import Top.Types.Unification as Export 23 | -------------------------------------------------------------------------------- /src/Top/Types/Classes.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | -- 8 | -- Type classes and the standard reduction instances. A part of the code 9 | -- was taken from the paper "Typing Haskell in Haskell". 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Top.Types.Classes where 14 | 15 | import Control.Monad 16 | import qualified Data.Map as M 17 | import Top.Types.Primitive 18 | import Top.Types.Qualification 19 | import Top.Types.Substitution 20 | import Top.Types.Synonym 21 | import Top.Types.Unification 22 | 23 | ---------------------------------------------------------------------- 24 | -- * Class predicates 25 | {- 26 | type Predicates = [Predicate] 27 | data Predicate = Predicate String Tp deriving Eq 28 | 29 | instance Show Predicate where 30 | show (Predicate s tp) = if priorityOfType tp == 2 31 | then s ++ " " ++ show tp 32 | else s ++ " (" ++ show tp ++ ")" 33 | 34 | instance Substitutable Predicate where 35 | sub |-> (Predicate s tp) = Predicate s (sub |-> tp) 36 | ftv (Predicate _ tp) = ftv tp 37 | 38 | instance HasTypes Predicate where 39 | getTypes (Predicate _ tp) = [tp] 40 | changeTypes f (Predicate s tp) = Predicate s (f tp) 41 | 42 | instance ShowQualifiers Predicate 43 | 44 | ---------------------------------------------------------------------- 45 | -- * Class environments and instances 46 | 47 | type ClassEnvironment = M.Map String Class 48 | type Class = ([String], Instances) 49 | type Instances = [Instance] 50 | type Instance = (Predicate, Predicates) 51 | 52 | -- |The empty class environment 53 | emptyClassEnvironment :: ClassEnvironment 54 | emptyClassEnvironment = M.empty 55 | 56 | matchPredicates :: OrderedTypeSynonyms -> Predicate -> Predicate -> Maybe MapSubstitution 57 | matchPredicates synonyms (Predicate s1 t1) (Predicate s2 t2) 58 | | s1 == s2 = case mguWithTypeSynonyms synonyms (freezeVariablesInType t1) t2 of 59 | Left _ -> Nothing 60 | Right (_, s) -> Just (M.map unfreezeVariablesInType s) 61 | | otherwise = Nothing 62 | 63 | insertInstance :: String -> Instance -> ClassEnvironment -> ClassEnvironment 64 | insertInstance className inst env = 65 | case M.lookup className env of 66 | Nothing -> M.insert className ([], [inst]) env 67 | Just (parents, insts) -> M.insert className (parents, inst:insts) env 68 | 69 | ---------------------------------------------------------------------- 70 | -- * Class environment 71 | 72 | inClassEnvironment :: String -> ClassEnvironment -> Bool 73 | inClassEnvironment = M.member 74 | 75 | superclassPaths :: String -> String -> ClassEnvironment -> [[String]] 76 | superclassPaths from to cs 77 | | from == to = [[to]] 78 | | otherwise = [ from : path | sc <- superclasses from cs, path <- superclassPaths sc to cs ] 79 | 80 | -- |For example, Eq is a superclass of Ord 81 | superclasses :: String -> ClassEnvironment -> [String] 82 | superclasses s cs = maybe [] fst (M.lookup s cs) 83 | 84 | instances :: String -> ClassEnvironment -> Instances 85 | instances s cs = maybe [] snd (M.lookup s cs) 86 | 87 | ---------------------------------------------------------------------- 88 | -- * Head normal form 89 | 90 | inHeadNormalForm :: Predicate -> Bool 91 | inHeadNormalForm (Predicate _ tp) = hnf tp 92 | where hnf (TVar _) = True 93 | hnf (TCon _) = False 94 | hnf (TApp t _) = hnf t 95 | 96 | listToHeadNormalForm :: OrderedTypeSynonyms -> ClassEnvironment -> Predicates -> Maybe Predicates 97 | listToHeadNormalForm synonyms classes ps = 98 | do pss <- mapM (toHeadNormalForm synonyms classes) ps 99 | return (concat pss) 100 | 101 | toHeadNormalForm :: OrderedTypeSynonyms -> ClassEnvironment -> Predicate -> Maybe Predicates 102 | toHeadNormalForm synonyms classes p 103 | | inHeadNormalForm p = Just [p] 104 | | otherwise = do ps <- byInstance synonyms classes p 105 | listToHeadNormalForm synonyms classes ps 106 | 107 | ---------------------------------------------------------------------- 108 | -- * Entailment 109 | 110 | bySuperclass :: ClassEnvironment -> Predicate -> Predicates 111 | bySuperclass classes p@(Predicate s tp) = 112 | p : concat [ bySuperclass classes (Predicate s' tp) | s' <- superclasses s classes ] 113 | 114 | byInstance :: OrderedTypeSynonyms -> ClassEnvironment -> Predicate -> Maybe Predicates 115 | byInstance synonyms classes p@(Predicate s _) = 116 | let tryInstance (p',list) = do sub <- matchPredicates synonyms p p' 117 | Just (sub |-> list) 118 | in msum [ tryInstance it | it <- instances s classes ] 119 | 120 | entail :: OrderedTypeSynonyms -> ClassEnvironment -> Predicates -> Predicate -> Bool 121 | entail synonyms classes ps p = 122 | scEntail classes ps p || 123 | case byInstance synonyms classes p of 124 | Nothing -> False 125 | Just qs -> all (entail synonyms classes ps) qs 126 | 127 | entailList :: OrderedTypeSynonyms -> ClassEnvironment -> Predicates -> Predicates -> Bool 128 | entailList synonyms classes ps = all (entail synonyms classes ps) 129 | 130 | scEntail :: ClassEnvironment -> Predicates -> Predicate -> Bool 131 | scEntail classes ps p = any (p `elem`) (map (bySuperclass classes) ps) 132 | 133 | ---------------------------------------------------------------------- 134 | -- * Context reduction 135 | 136 | newtype ReductionError a = ReductionError a 137 | deriving Show 138 | 139 | contextReduction :: OrderedTypeSynonyms -> ClassEnvironment -> Predicates -> 140 | (Predicates, [ReductionError Predicate]) 141 | contextReduction synonyms classes ps = 142 | let op p (a,b) = case toHeadNormalForm synonyms classes p of 143 | Just qs -> (qs++a,b) 144 | Nothing -> (a,ReductionError p : b) 145 | (predicates, errors) = foldr op ([], []) ps 146 | 147 | loop rs [] = rs 148 | loop rs (x:xs) | scEntail classes (rs++xs) x = loop rs xs 149 | | otherwise = loop (x:rs) xs 150 | 151 | in (loop [] predicates, errors) 152 | 153 | associatedContextReduction :: OrderedTypeSynonyms -> ClassEnvironment -> [(Predicate, a)] -> 154 | ([(Predicate,a)], [ReductionError (Predicate, a)]) 155 | associatedContextReduction synonyms classes ps = 156 | let op (predicate, a) (reduced, es) = 157 | case toHeadNormalForm synonyms classes predicate of 158 | Just qs -> ([(p,a) | p <- qs]++reduced,es) 159 | Nothing -> (reduced,ReductionError (predicate, a) : es) 160 | (predicates, errors) = foldr op ([], []) ps 161 | 162 | loop rs [] = rs 163 | loop rs (q:qs) | entailed = loop rs qs 164 | | otherwise = loop (q:rs) qs 165 | where entailed = scEntail classes (map fst (rs++qs)) (fst q) 166 | 167 | in (loop [] predicates, errors) 168 | 169 | ---------------------------------------------------------------------- 170 | -- * Standard class environment 171 | 172 | -- This environment is only used at three places: 173 | -- o MiscErrors.ag 174 | -- o Warnings.ag 175 | -- o Collect.ag (initialization in import environment) 176 | standardClasses :: ClassEnvironment 177 | standardClasses = M.fromList $ 178 | 179 | -- only two instances for Num: Int and Float 180 | ( "Num", 181 | ( ["Eq","Show"] -- superclasses 182 | , [ (Predicate "Num" intType , []) -- instances 183 | , (Predicate "Num" floatType, []) 184 | ] 185 | ) 186 | ) : 187 | ( "Enum", ([], [ (Predicate "Enum" tp, []) | tp <- [voidType, charType, intType, floatType, boolType]]) 188 | ) : 189 | -- Eq, Ord and Show all have the same instances 190 | [ ("Eq" , ([] , makeInstances "Eq" )) 191 | , ("Ord", (["Eq"], makeInstances "Ord" )) 192 | , ("Show", ([], makeInstances "Show")) 193 | ] 194 | 195 | where 196 | makeInstances className = 197 | let basicTypes = [intType, floatType, boolType, charType] 198 | makeTupleInstance i = 199 | ( Predicate className (tupleType [ TVar n | n <- [1..i] ]) 200 | , [ Predicate className (TVar n) | n <- [1..i] ] 201 | ) 202 | in (Predicate className (listType (TVar 0)), [Predicate className (TVar 0)]) -- instance for Lists 203 | : [ (Predicate className tp, []) | tp <- basicTypes ] 204 | ++ map makeTupleInstance (0 : [2..10]) 205 | -} 206 | -------------------------------------------------------------------------------- /src/Top/Types/Kinds.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | -- 8 | -- Kinds can be represented by a type. 9 | -- 10 | ----------------------------------------------------------------------------- 11 | 12 | module Top.Types.Kinds where 13 | 14 | import Top.Types.Primitive 15 | import Top.Types.Quantification 16 | import Top.Types.Schemes 17 | import Top.Types.Substitution 18 | 19 | {- 20 | 21 | type Kind = Tp 22 | type Kinds = [Kind] 23 | type KindScheme = TpScheme 24 | 25 | -- |Star is the kind of all values. 26 | star :: Kind 27 | star = TCon "*" 28 | 29 | -- |In traditional kind inference systems, a kind cannot contain variables. 30 | -- At some point in the inference process the kind variables are defaulted 31 | -- to star. 32 | defaultToStar :: Kind -> Kind 33 | defaultToStar kind = 34 | let sub = listToSubstitution [ (i, star) | i <- ftv kind ] 35 | in sub |-> kind 36 | 37 | -- |A function to show kinds. 38 | showKind :: Kind -> String 39 | showKind kind = 40 | let sub = listToSubstitution [ (i, TCon ('k':show i)) | i <- ftv kind ] 41 | in show (sub |-> kind) 42 | 43 | showKindScheme :: KindScheme -> String 44 | showKindScheme scheme = 45 | let sub = listToSubstitution 46 | $ [ (i, TCon ('k':show j)) | (i, j) <- zip (quantifiers scheme) [1 :: Int ..] ] 47 | ++ [ (i, TCon ("_k"++show i)) | i <- ftv scheme ] 48 | in show (sub |-> unquantify scheme) 49 | 50 | -} 51 | -------------------------------------------------------------------------------- /src/Top/Types/Primitive.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | -- 8 | -- This module contains a data type to represent (plain) types, some basic 9 | -- functionality for types, and an instance for Show. 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Top.Types.Primitive (HasTypes(getTypes, changeTypes)) where 14 | 15 | import Data.Char (isDigit, isSpace) 16 | import Data.List (isPrefixOf, union) 17 | import qualified PatternUnify.Tm as Tm 18 | ----------------------------------------------------------------------------- 19 | -- * Data type definition 20 | 21 | -- type Tps = [Tp] 22 | -- -- |A data type to represent monotypes. Note that 'Type' is already in use 23 | -- -- in the Unified Haskell Architecture (UHA) which is used in the Helium compiler 24 | -- data Tp = TVar Int -- ^The type variables are numbered. 25 | -- | TCon String -- ^A type constant is represented by a string. 26 | -- | TApp Tp Tp -- ^The application of two Top.Types. Not all types that can be 27 | -- -- constructed are well-formed. 28 | -- deriving (Eq, Ord) 29 | 30 | ---------------------------------------------------------------------- 31 | -- * Common types 32 | 33 | -- intType, charType, floatType, boolType, stringType :: Tp 34 | -- intType = TCon "Int" 35 | -- charType = TCon "Char" 36 | -- floatType = TCon "Float" 37 | -- boolType = TCon "Bool" 38 | -- stringType = TCon "String" 39 | 40 | -- infixr 5 .->. 41 | -- -- |Constructs a function type from one type to another. This operator is 42 | -- -- left associative. 43 | -- (.->.) :: Tp -> Tp -> Tp 44 | -- t1 .->. t2 = TApp (TApp (TCon "->") t1) t2 45 | -- 46 | -- -- |For instance, @(listType intType)@ represents @[Int]@ 47 | -- listType :: Tp -> Tp 48 | -- listType = TApp (TCon "[]") 49 | -- 50 | -- -- |For instance, @(ioType boolType)@ represents @(IO Bool)@ 51 | -- ioType :: Tp -> Tp 52 | -- ioType = TApp (TCon "IO") 53 | -- 54 | -- -- |A cathesian product of zero or more Top.Types. For instance, 55 | -- -- @(tupleType [])@ represents @()@, and @(tupleType [charType, stringType])@ 56 | -- -- represents @(Char,String)@ 57 | -- tupleType :: Tps -> Tp 58 | -- tupleType tps = let name | null tps = "()" 59 | -- | otherwise = "("++replicate (length tps-1) ','++")" 60 | -- in foldl TApp (TCon name) tps 61 | -- 62 | -- -- |The unit type. A special instance of of tuple type. 63 | -- voidType :: Tp 64 | -- voidType = tupleType [] 65 | -- 66 | -- ---------------------------------------------------------------------- 67 | -- -- * Basic functionality 68 | -- 69 | -- -- |Returns the list of type variables of a type. (no duplicates) 70 | -- variablesInType :: Tp -> [Int] 71 | -- variablesInType tp = case tp of 72 | -- TVar i -> [i] 73 | -- TCon _ -> [] 74 | -- TApp t1 t2 -> variablesInType t1 `union` variablesInType t2 75 | -- 76 | -- -- |Returns the list of type constants of a type. (no duplicates) 77 | -- constantsInType :: Tp -> [String] 78 | -- constantsInType tp = case tp of 79 | -- TVar _ -> [] 80 | -- TCon s -> [s] 81 | -- TApp t1 t2 -> constantsInType t1 `union` constantsInType t2 82 | -- 83 | -- -- |Returns the left spine of a type. For instance, if type @t@ 84 | -- -- is @Either Bool [Int]@, then @leftSpine t@ is @(Either,[Bool,[Int]])@. 85 | -- leftSpine :: Tp -> (Tp,Tps) 86 | -- leftSpine = rec [] where 87 | -- rec tps (TApp t1 t2) = rec (t2:tps) t1 88 | -- rec tps tp = (tp,tps) 89 | -- 90 | -- -- |Returns the right spine of a function type. For instance, 91 | -- -- if type @t@ is @Int -> (Bool -> String)@, then @functionSpine t@ 92 | -- -- is @([Int,Bool],String)@. 93 | -- functionSpine :: Tp -> (Tps,Tp) 94 | -- functionSpine = rec [] where 95 | -- rec tps (TApp (TApp (TCon "->") t1) t2) = rec (t1:tps) t2 96 | -- rec tps tp = (reverse tps,tp) 97 | -- 98 | -- -- |Returns the right spine of a function type of a maximal length. 99 | -- functionSpineOfLength :: Int -> Tp -> (Tps, Tp) 100 | -- functionSpineOfLength i tp = 101 | -- let (as, a ) = functionSpine tp 102 | -- (bs, cs) = splitAt i as 103 | -- in (bs, foldr (.->.) a cs) 104 | -- 105 | -- -- |Returns the arity of a type, that is, the number of expected arguments. 106 | -- arityOfTp :: Tp -> Int 107 | -- arityOfTp = length . fst . functionSpine 108 | -- 109 | -- -- |The priority of a type, primarily used for the insertion of parentheses 110 | -- -- in pretty printing. 111 | -- priorityOfType :: Tp -> Int 112 | -- priorityOfType tp = case leftSpine tp of 113 | -- (TCon "->",[_,_] ) -> 0 114 | -- (_ ,[] ) -> 2 115 | -- (TCon "[]",[_] ) -> 2 116 | -- (TCon s ,_ ) | isTupleConstructor s -> 2 117 | -- _ -> 1 118 | -- 119 | -- -- |All the type variables in a type are frozen by turning them into a type 120 | -- -- constant. The integer numeral is prefixed with an underscore ('_'). 121 | -- freezeVariablesInType :: Tp -> Tp 122 | -- freezeVariablesInType tp = 123 | -- case tp of 124 | -- TVar i -> TCon ('_':show i) 125 | -- TCon s -> TCon s 126 | -- TApp l r -> TApp (freezeVariablesInType l) (freezeVariablesInType r) 127 | -- 128 | -- -- |Recover the type variables that are frozen in a type. 129 | -- unfreezeVariablesInType :: Tp -> Tp 130 | -- unfreezeVariablesInType tp = 131 | -- case tp of 132 | -- TVar i -> TVar i 133 | -- TCon ('_':s) | all isDigit s && not (null s) 134 | -- -> TVar (read s) 135 | -- TCon s -> TCon s 136 | -- TApp l r -> TApp (unfreezeVariablesInType l) (unfreezeVariablesInType r) 137 | -- 138 | -- ---------------------------------------------------------------------- 139 | -- * Predicates on types 140 | 141 | -- isTVar :: Tp -> Bool 142 | -- isTVar (TVar _) = True 143 | -- isTVar _ = False 144 | -- 145 | -- isTCon :: Tp -> Bool 146 | -- isTCon (TCon _) = True 147 | -- isTCon _ = False 148 | -- 149 | -- isTApp :: Tp -> Bool 150 | -- isTApp (TApp _ _) = True 151 | -- isTApp _ = False 152 | -- 153 | -- isFunctionType :: Tp -> Bool 154 | -- isFunctionType (TApp (TApp (TCon "->") _) _) = True 155 | -- isFunctionType _ = False 156 | -- 157 | -- isTupleConstructor :: String -> Bool 158 | -- isTupleConstructor ('(':[]) = False 159 | -- isTupleConstructor ('(':cs) = all (','==) (init cs) && last cs == ')' 160 | -- isTupleConstructor _ = False 161 | -- 162 | -- isIOType :: Tp -> Bool 163 | -- isIOType (TApp (TCon "IO") _) = True 164 | -- isIOType _ = False 165 | 166 | ---------------------------------------------------------------------- 167 | -- Show and Read instances 168 | 169 | -- instance Show Tp where 170 | -- -- parenthesis are needed when the type must be shown as a part of 171 | -- -- some other data type 172 | -- showsPrec prio theType rest = 173 | -- parIf (prio > 0) (showTp theType) ++ rest 174 | -- 175 | -- where 176 | -- showTp tp = 177 | -- case leftSpine tp of 178 | -- (TCon "->",[t1,t2]) -> rec (<1) t1 ++ " -> " ++ rec (const False) t2 179 | -- (TVar i ,[] ) -> 'v' : show i 180 | -- (TCon s ,[] ) -> s 181 | -- (TCon "[]",[t1] ) -> "[" ++ rec (const False) t1 ++ "]" 182 | -- (TCon s ,ts ) | isTupleConstructor s -> let ts' = map (rec (const False)) ts 183 | -- f [] = "" 184 | -- f xs = foldr1 (\x y -> x++", "++y) xs 185 | -- in "(" ++ f ts' ++ ")" 186 | -- (t,ts) -> unwords (map (rec (<2)) (t:ts)) 187 | -- 188 | -- rec p t = parIf (p (priorityOfType t)) (showTp t) 189 | -- parIf True s = "("++s++")" 190 | -- parIf False s = s 191 | -- 192 | -- instance Read Tp where 193 | -- readsPrec _ = tpParser 194 | 195 | -- tpParser :: String -> [(Tp, String)] 196 | -- tpParser = level0 197 | -- where 198 | -- level0 = foldr1 (.->.) <$> seplist (tok "->") level1 199 | -- level1 = foldl1 TApp <$> list1 level2 200 | -- level2 = ident 201 | -- <|> (listType <$> bracks level0) 202 | -- <|> ((\xs -> if length xs == 1 then head xs else tupleType xs) <$> pars (commaList level0)) 203 | -- 204 | -- ident xs = 205 | -- case break (\c -> isSpace c || c `elem` "[]()-,") (dropWhile isSpace xs) of 206 | -- ([], _) -> [] 207 | -- (s, xs2) | length s > 1 && "v" `isPrefixOf` s && all isDigit (drop 1 s) 208 | -- -> [ (TVar (read $ drop 1 s), xs2) ] 209 | -- | otherwise -> [ (TCon s, xs2) ] 210 | -- 211 | -- (p <*> q) xs = [ (f a, xs2) | (f, xs1) <- p xs, (a, xs2) <- q xs1 ] 212 | -- (f <$> p) xs = [ (f a, xs1) | (a, xs1) <- p xs ] 213 | -- (p <|> q) xs = p xs ++ q xs 214 | -- p <* q = const <$> p <*> q 215 | -- p *> q = flip const <$> p <*> q 216 | -- succeed a xs = [(a, xs)] 217 | -- tok s xs = 218 | -- let ys = dropWhile isSpace xs 219 | -- in [ (s, drop (length s) ys) | not (null ys), s `isPrefixOf` ys ] 220 | -- pars p = tok "(" *> p <* tok ")" 221 | -- bracks p = tok "[" *> p <* tok "]" 222 | -- list p = ((:) <$> p <*> list p) <|> succeed [] 223 | -- list1 p = (:) <$> p <*> list p 224 | -- seplist sep p = (:) <$> p <*> list (sep *> p) 225 | -- commaList p = seplist (tok ",") p <|> succeed [] 226 | 227 | ---------------------------------------------------------------------- 228 | -- The type class HasTypes 229 | 230 | class HasTypes a where 231 | getTypes :: a -> [Tm.VAL] 232 | changeTypes :: (Tm.VAL -> Tm.VAL) -> a -> a 233 | 234 | instance HasTypes Tm.VAL where 235 | getTypes tp = [tp] 236 | changeTypes = ($) 237 | 238 | instance HasTypes a => HasTypes [a] where 239 | getTypes = concatMap getTypes 240 | changeTypes f = map (changeTypes f) 241 | 242 | instance (HasTypes a, HasTypes b) => HasTypes (a, b) where 243 | getTypes (a, b) = getTypes a ++ getTypes b 244 | changeTypes f (a, b) = (changeTypes f a, changeTypes f b) 245 | 246 | instance HasTypes a => HasTypes (Maybe a) where 247 | getTypes = maybe [] getTypes 248 | changeTypes = fmap . changeTypes 249 | 250 | instance (HasTypes a, HasTypes b) => HasTypes (Either a b) where 251 | getTypes = either getTypes getTypes 252 | changeTypes f = either (Left . changeTypes f) (Right . changeTypes f) 253 | -------------------------------------------------------------------------------- /src/Top/Types/Qualification.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | -- 8 | -- Qualification of types (for instance, predicates to deal with type classes). 9 | -- 10 | ----------------------------------------------------------------------------- 11 | 12 | module Top.Types.Qualification where 13 | 14 | import Top.Types.Primitive 15 | import Top.Types.Substitution 16 | import Data.List 17 | 18 | ----------------------------------------------------------------------------- 19 | -- * Qualification 20 | 21 | newtype Qualification q a = Qualification (q, a) 22 | 23 | split :: Qualification q a -> (q, a) 24 | split (Qualification t) = t 25 | 26 | infixr 2 .=>. 27 | 28 | (.=>.) :: q -> a -> Qualification q a 29 | (.=>.) = curry Qualification 30 | 31 | qualifiers :: Qualification q a -> q 32 | qualifiers = fst . split 33 | 34 | unqualify :: Qualification q a -> a 35 | unqualify = snd . split 36 | 37 | qualify :: (Substitutable context, Substitutable q, Substitutable a) => context -> [q] -> a -> Qualification [q] a 38 | qualify context preds tp = 39 | let is = ftv tp \\ ftv context 40 | p = any (`elem` is) . ftv 41 | in (filter p preds .=>. tp) 42 | 43 | instance (Substitutable q, Substitutable a) => Substitutable (Qualification q a) where 44 | sub |-> (Qualification t) = Qualification (sub |-> t) 45 | ftv (Qualification t) = ftv t 46 | 47 | instance (HasTypes q, HasTypes a) => HasTypes (Qualification q a) where 48 | getTypes (Qualification t) = getTypes t 49 | changeTypes f (Qualification t) = Qualification (changeTypes f t) 50 | 51 | instance (ShowQualifiers q, Show a) => Show (Qualification q a) where 52 | show (Qualification (q, a)) = 53 | showContext q ++ show a 54 | 55 | class Show a => ShowQualifiers a where 56 | showQualifiers :: a -> [String] 57 | -- default definition 58 | showQualifiers = (:[]) . show 59 | 60 | showContext :: ShowQualifiers a => a -> String 61 | showContext = showContextSimple . showQualifiers 62 | 63 | showContextSimple :: [String] -> String 64 | showContextSimple [] = "" 65 | showContextSimple [x] = x ++ " => " 66 | showContextSimple xs = "(" ++ intercalate ", " xs ++ ") => " 67 | 68 | instance (ShowQualifiers a, ShowQualifiers b) => ShowQualifiers (a, b) where 69 | showQualifiers (a, b) = showQualifiers a ++ showQualifiers b 70 | 71 | instance ShowQualifiers a => ShowQualifiers [a] where 72 | showQualifiers = concatMap showQualifiers -------------------------------------------------------------------------------- /src/Top/Types/Quantification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | -- 9 | -- Universal and existential quantification of types 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Top.Types.Quantification () where 14 | 15 | import Data.List 16 | import Data.Maybe 17 | import Top.Types.Primitive 18 | import Top.Types.Substitution 19 | import Utils (internalError) 20 | 21 | import qualified PatternUnify.Tm as Tm 22 | import qualified Unbound.Generics.LocallyNameless as Ln 23 | 24 | ----------------------------------------------------------------------------- 25 | -- * Quantification 26 | {- 27 | newtype Quantification q a = Quantification ([Tm.Nom], QuantorMap, a) 28 | 29 | type QuantorMap = [(Tm.Nom, String)] 30 | 31 | withoutQuantors :: Quantification q a -> Bool 32 | withoutQuantors (Quantification (is, _, _)) = null is 33 | 34 | showQuantor :: Show q => Quantification q a -> String 35 | showQuantor = show . f where 36 | f :: Quantification q a -> q 37 | f = internalError "Top.Types.Quantification" "showQuantor" "quantor unknown" 38 | 39 | noQuantifiers :: a -> Quantification q a 40 | noQuantifiers a = Quantification ([], [], a) 41 | 42 | quantifiers :: Quantification q a -> [Tm.Nom] 43 | quantifiers (Quantification (is, _, _)) = is 44 | 45 | unquantify :: Quantification q a -> a 46 | unquantify (Quantification (_, _, a)) = a 47 | 48 | instance Substitutable a => Substitutable (Quantification q a) where 49 | sub |-> (Quantification (is, qmap, a)) = Quantification (is, qmap, removeDom is sub |-> a) 50 | ftv (Quantification (is, _ , a)) = ftv a \\ is 51 | 52 | instance HasTypes a => HasTypes (Quantification q a) where 53 | getTypes (Quantification (_, _, a)) = getTypes a 54 | changeTypes f (Quantification (is, qmap, a)) = Quantification (is, qmap, changeTypes f a) 55 | 56 | introduceTypeVariables :: Substitutable a => Tm.Nom -> Quantification q a -> (Tm.Nom, a) 57 | introduceTypeVariables i (Quantification (qs, _, a)) = error "introduceTypeVariables" 58 | -- let sub = listToSubstitution (zip qs (map (Tm.var . Ln.s2n . show) [i..])) 59 | -- in (i + length qs, sub |-> a) 60 | 61 | introduceSkolemConstants :: Substitutable a => Tm.Nom -> Quantification q a -> (Tm.Nom, a) 62 | introduceSkolemConstants i (Quantification (qs, _, a)) = error "introduceSkolemConstants" 63 | -- let sub = listToSubstitution (zip qs (map (makeSkolemConstant . Ln.s2n . show) [i..])) 64 | -- in (i + length qs, sub |-> a) 65 | 66 | bindTypeVariables :: Substitutable a => [Tm.Nom] -> a -> Quantification q a 67 | bindTypeVariables is a = Quantification (is `intersect` ftv a, [], a) 68 | 69 | bindSkolemConstants :: HasSkolems a => [Tm.Nom] -> a -> Quantification q a 70 | bindSkolemConstants scs a = 71 | let scs' = scs `union` allSkolems a 72 | skMap = [ (i, Tm.var i) | i <- scs' ] 73 | in Quantification (scs', [], changeSkolems skMap a) 74 | 75 | getQuantorMap :: Quantification q a -> QuantorMap 76 | getQuantorMap (Quantification (_, qm, _)) = qm 77 | 78 | ----------------------------------------------------------------------------- 79 | -- * Universal quantification 80 | 81 | data Universal 82 | type Forall = Quantification Universal 83 | 84 | instance Show Universal where 85 | show = const "forall" 86 | 87 | instantiate, skolemize :: Substitutable a => Tm.Nom -> Forall a -> (Tm.Nom, a) 88 | instantiate = introduceTypeVariables 89 | skolemize = introduceSkolemConstants 90 | 91 | generalize :: (Substitutable context, Substitutable a) => context -> a -> Forall a 92 | generalize context a = 93 | quantify (ftv a \\ ftv context) a 94 | 95 | generalizeAll :: Substitutable a => a -> Forall a 96 | generalizeAll a = quantify (ftv a) a 97 | 98 | quantify :: Substitutable a => [Tm.Nom] -> a -> Forall a 99 | quantify = bindTypeVariables 100 | 101 | unskolemize :: HasSkolems a => [Tm.Nom] -> a -> Forall a 102 | unskolemize = bindSkolemConstants 103 | 104 | ----------------------------------------------------------------------------- 105 | -- * Existential quantification 106 | 107 | data Existential 108 | type Exists = Quantification Existential 109 | 110 | instance Show Existential where 111 | show = const "exists" 112 | 113 | open, reveal :: Substitutable a => Tm.Nom -> Exists a -> (Tm.Nom, a) 114 | open = introduceSkolemConstants 115 | reveal = introduceTypeVariables 116 | 117 | close :: HasSkolems a => [Tm.Nom] -> a -> Exists a 118 | close = bindSkolemConstants 119 | 120 | unreveal :: Substitutable a => [Tm.Nom] -> a -> Exists a 121 | unreveal = bindTypeVariables 122 | 123 | ----------------------------------------------------------------------------- 124 | -- * Skolemization 125 | 126 | skolemPrefix :: String 127 | skolemPrefix = "_" 128 | 129 | makeSkolemConstant :: Tm.Nom -> Tm.VAL 130 | makeSkolemConstant = error "makeSkolemConstant" --Tm.Con . (skolemPrefix++) . show 131 | 132 | fromSkolemString :: String -> Maybe Tm.Nom 133 | fromSkolemString s 134 | | skolemPrefix `isPrefixOf` s = 135 | Just (read (drop (length skolemPrefix) s)) 136 | | otherwise = Nothing 137 | 138 | skolemizeFTV :: Substitutable a => a -> a 139 | skolemizeFTV a = 140 | let sub = listToSubstitution [ (i, makeSkolemConstant i) | i <- ftv a ] 141 | in sub |-> a 142 | 143 | class HasSkolems a where 144 | allSkolems :: a -> [Tm.Nom] 145 | changeSkolems :: [(Tm.Nom, Tm.VAL)] -> a -> a 146 | 147 | instance HasSkolems Tm.VAL where 148 | -- allSkolems (TVar _) = [] 149 | -- allSkolems (TCon s) = case fromSkolemString s of 150 | -- Just i -> [i] 151 | -- Nothing -> [] 152 | -- allSkolems (TApp l r) = allSkolems l `union` allSkolems r 153 | -- 154 | -- changeSkolems skMap = rec where 155 | -- rec tp@(TVar _) = tp 156 | -- rec tp@(TCon s) = case fromSkolemString s of 157 | -- Just i -> fromMaybe tp (lookup i skMap) 158 | -- Nothing -> tp 159 | -- rec (TApp l r) = TApp (rec l) (rec r) 160 | 161 | instance HasSkolems a => HasSkolems [a] where 162 | allSkolems = foldr (union . allSkolems) [] 163 | changeSkolems skMap = map (changeSkolems skMap) 164 | 165 | ----------------------------------------------------------------------------- 166 | -- * Pretty printing 167 | 168 | data ShowQuantorOptions = ShowQuantorOptions 169 | { showTopLevelQuantors :: Bool 170 | , dontUseIdentifiers :: [String] 171 | , variablePrefix :: String 172 | , showAllTheSame :: Bool 173 | , useTheNameMap :: Bool 174 | } 175 | 176 | defaultOptions :: ShowQuantorOptions 177 | defaultOptions = ShowQuantorOptions 178 | { showTopLevelQuantors = False 179 | , dontUseIdentifiers = [] 180 | , variablePrefix = "v" 181 | , showAllTheSame = False 182 | , useTheNameMap = True 183 | } 184 | 185 | showQuantors :: ShowQuantors a => a -> String 186 | showQuantors = showQuantorsWithout (defaultOptions { showTopLevelQuantors = True }) 187 | 188 | -- |This class can deal with the pretty printing of (possibly nested) quantifiers. 189 | class Show a => ShowQuantors a where 190 | showQuantorsWithout :: ShowQuantorOptions -> a -> String 191 | 192 | -- default definition 193 | showQuantorsWithout = const show 194 | 195 | instance ShowQuantors Tm.VAL 196 | 197 | instance (Substitutable a, ShowQuantors a, Show q) => Show (Quantification q a) where 198 | show = showQuantorsWithout defaultOptions 199 | 200 | instance (Substitutable a, ShowQuantors a, Show q) => ShowQuantors (Quantification q a) where 201 | showQuantorsWithout options q@(Quantification (is, qmap, a)) = 202 | let 203 | qs = is `intersect` ftv a 204 | quantorText | null qs || not (showTopLevelQuantors options) = "" 205 | | otherwise = unwords (showQuantor q : map (\i -> show (sub |-> Tm.var i)) qs ++ [". "]) 206 | dontUse = dontUseIdentifiers options 207 | -- find an appropriate name for bound type variables that are in the name map 208 | qmap1 | not (useTheNameMap options) || showAllTheSame options = [] 209 | | otherwise = 210 | let op (rest, donts) (i,n) 211 | | i `elem` qs = let ints = [1..] :: [Int] 212 | s :: Tm.Can 213 | s = head [ n ++ extra 214 | | extra <- "" : map show ints 215 | , n ++ extra `notElem` donts 216 | ] 217 | in ((i,s):rest, s:donts) 218 | | otherwise = (rest, donts) 219 | in fst (foldl op ([], dontUse) qmap) 220 | dontUse1 = map snd qmap1 ++ dontUse 221 | -- find a name for the other bound type variables 222 | qmap2 | showAllTheSame options = [] 223 | | otherwise = zip (filter (`notElem` map fst qmap1) qs) (variableList \\ dontUse1) 224 | dontUse2 = map snd qmap2 ++ dontUse1 225 | frees = ftv a \\ map fst (qmap1 ++ qmap2) 226 | sub = listToSubstitution $ [ (i, Tm.Con s) | (i,s) <- qmap1 ++ qmap2 ] 227 | ++ [ (i, Tm.Con (variablePrefix options ++ show i)) | i <- frees ] 228 | newOptions = options { dontUseIdentifiers = dontUse2 229 | , showTopLevelQuantors = True 230 | } 231 | in 232 | quantorText ++ showQuantorsWithout newOptions (sub |-> a) 233 | 234 | -- |List of unique identifiers.(a, b, .., z, a1, b1 .., z1, a2, ..) 235 | variableList :: [String] 236 | variableList = [ [x] | x <- ['a'..'z'] ] 237 | ++ [ x:show i | i <- [1 :: Int ..], x <- ['a'..'z'] ] 238 | -} 239 | -------------------------------------------------------------------------------- /src/Top/Types/Schemes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | -- 9 | -- A representation of type schemes. A type scheme is a (qualified) type 10 | -- with a number of quantifiers (foralls) in front of it. A partial mapping 11 | -- from type variable (Int) to their name (String) is preserved. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Top.Types.Schemes where 16 | 17 | import Top.Types.Primitive 18 | import Top.Types.Quantification 19 | import Top.Types.Qualification 20 | import Top.Types.Substitution 21 | import Top.Types.Synonym 22 | import Top.Types.Unification 23 | import Top.Types.Classes 24 | import Data.List 25 | import qualified Data.Map as M 26 | {- 27 | ---------------------------------------------------------------------- 28 | -- * Type schemes 29 | 30 | -- |A type scheme consists of a list of quantified type variables, a finite map 31 | -- that partially maps these type variables to their original identifier, and a 32 | -- qualified type. 33 | type TpScheme = Forall QType 34 | type QType = Qualification Predicates Tp 35 | 36 | -- |A type class to convert something into a type scheme 37 | class IsTpScheme a where 38 | toTpScheme :: a -> TpScheme 39 | 40 | instance IsTpScheme TpScheme where 41 | toTpScheme = id 42 | 43 | instance IsTpScheme QType where 44 | toTpScheme = noQuantifiers 45 | 46 | instance IsTpScheme Tp where 47 | toTpScheme = noQuantifiers . ([] .=>.) 48 | 49 | ---------------------------------------------------------------------- 50 | -- * Basic functionality for types and type schemes 51 | 52 | -- |Determine the arity of a type scheme. 53 | arityOfTpScheme :: TpScheme -> Int 54 | arityOfTpScheme = arityOfTp . unqualify . unquantify 55 | 56 | genericInstanceOf :: OrderedTypeSynonyms -> ClassEnvironment -> TpScheme -> TpScheme -> Bool 57 | genericInstanceOf synonyms classes scheme1 scheme2 = 58 | let -- monomorphic type variables are treated as constants 59 | s1 = skolemizeFTV scheme1 60 | s2 = skolemizeFTV scheme2 61 | -- substitution to fix the type variables in the first type scheme 62 | sub = listToSubstitution (zip (quantifiers s1) [ TCon ('+':show i) | i <- [0 :: Int ..]]) 63 | (ps1, tp1) = split (sub |-> unquantify s1) 64 | (ps2, tp2) = split (snd (instantiate 123456789 s2)) 65 | in case mguWithTypeSynonyms synonyms tp1 tp2 of 66 | Left _ -> False 67 | Right (_,sub2) -> entailList synonyms classes ps1 (sub2 |-> ps2) 68 | 69 | -- |Is the type scheme overloaded (does it contain predicates)? 70 | isOverloaded :: TpScheme -> Bool 71 | isOverloaded = not . null . qualifiers . unquantify 72 | 73 | makeScheme :: [Int] -> Predicates -> Tp -> TpScheme 74 | makeScheme monos preds tp = 75 | let is = ftv tp \\ monos 76 | p = any (`elem` is) . ftv 77 | in quantify is (filter p preds .=>. tp) 78 | 79 | instantiateWithNameMap :: Int -> TpScheme -> (Int, Predicates, Tp) -- get rid of this function. 80 | instantiateWithNameMap unique (Quantification (qs,nm,qtp)) = 81 | let sub = listToSubstitution [ (i,TCon s) | (i,s) <- nm, i `elem` qs ] 82 | (u, qtp') = instantiate unique (Quantification (qs \\ map fst nm, [], sub |-> qtp)) 83 | (ps, tp) = split qtp' 84 | in (u, ps, tp) 85 | 86 | instance (ShowQualifiers q, Show a) => ShowQuantors (Qualification q a) 87 | 88 | -- |A sigma is a type scheme or a type scheme variable 89 | type Scheme qs = Forall (Qualification qs Tp) 90 | 91 | data Sigma qs = SigmaVar SigmaVar 92 | | SigmaScheme (Scheme qs) 93 | type SigmaVar = Int 94 | 95 | instance (ShowQualifiers qs, Substitutable qs) => Show (Sigma qs) where 96 | show (SigmaVar i) = 's':show i 97 | show (SigmaScheme s) = show s 98 | 99 | instance Substitutable qs => Substitutable (Sigma qs) where 100 | _ |-> sv@(SigmaVar _) = sv 101 | sub |-> (SigmaScheme s) = SigmaScheme (sub |-> s) 102 | 103 | ftv (SigmaVar _) = [] 104 | ftv (SigmaScheme s) = ftv s 105 | 106 | instance (Substitutable qs, ShowQualifiers qs) => ShowQuantors (Sigma qs) where 107 | showQuantorsWithout options sigma = 108 | case sigma of 109 | SigmaVar _ -> show sigma 110 | SigmaScheme ts -> showQuantorsWithout options ts 111 | 112 | -- |A substitution for type scheme variables 113 | type TpSchemeMap = M.Map SigmaVar TpScheme 114 | 115 | type SigmaPreds = Sigma Predicates 116 | 117 | class IsSigmaPreds a where 118 | toSigmaPreds :: a -> SigmaPreds 119 | 120 | instance IsSigmaPreds SigmaPreds where toSigmaPreds = id 121 | instance IsSigmaPreds TpScheme where toSigmaPreds = SigmaScheme . toTpScheme 122 | instance IsSigmaPreds QType where toSigmaPreds = SigmaScheme . toTpScheme 123 | instance IsSigmaPreds Tp where toSigmaPreds = SigmaScheme . toTpScheme 124 | instance IsSigmaPreds Int where toSigmaPreds = SigmaVar 125 | -} 126 | -------------------------------------------------------------------------------- /src/Top/Types/Substitution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | ----------------------------------------------------------------------------- 5 | -- | License : GPL 6 | -- 7 | -- Maintainer : helium@cs.uu.nl 8 | -- Stability : provisional 9 | -- Portability : non-portable (requires extensions) 10 | -- 11 | -- This module contains a data type to represent (plain) types, some basic 12 | -- functionality for types, and an instance for Show. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Top.Types.Substitution where 17 | 18 | import Data.List (nub, union, (\\)) 19 | import qualified Data.Map as M 20 | import qualified Data.Set as S 21 | import Top.Types.Primitive 22 | import Utils (internalError) 23 | 24 | import qualified PatternUnify.Tm as Tm 25 | import qualified Unbound.Generics.LocallyNameless as Ln 26 | 27 | ---------------------------------------------------------------------- 28 | -- * Substitutions and substitutables 29 | 30 | infix 4 |-> 31 | 32 | class Substitution s where 33 | lookupInt :: Tm.Nom -> s -> Tm.VAL -- lookup the type of a type variable in a substitution 34 | removeDom :: [Tm.Nom] -> s -> s -- remove from the domain of the substitution 35 | restrictDom :: [Tm.Nom] -> s -> s -- restrict the domain of the substitution 36 | dom :: s -> [Tm.Nom] -- domain of substitution 37 | cod :: s -> [Tm.VAL] -- co-domain of substitution 38 | 39 | class Substitutable a where 40 | (|->) :: Substitution s => s -> a -> a -- apply substitution 41 | ftv :: a -> [Tm.Nom] -- free type variables 42 | 43 | -- |The next type variable that is not free (default is zero) 44 | nextFTV :: Substitutable a => a -> Tm.Nom 45 | nextFTV a = case ftv a of 46 | [] -> error "start TV" --0 47 | is -> error "incr TV" -- maximum is + 1 48 | 49 | ---------------------------------------------------------------------- 50 | -- * Substitution instances 51 | 52 | -- |A substitution represented by a finite map. 53 | type MapSubstitution = M.Map Tm.Nom Tm.VAL 54 | 55 | instance Substitution MapSubstitution where 56 | 57 | lookupInt i = M.findWithDefault (Tm.var i) i 58 | removeDom = flip (foldr M.delete) 59 | restrictDom is = let set = S.fromList is 60 | in M.filterWithKey (\i _ -> S.member i set) 61 | 62 | dom = M.keys 63 | cod = M.elems 64 | 65 | emptySubst :: MapSubstitution 66 | emptySubst = M.empty 67 | 68 | -- |Compose two finite map substitutions: safe. 69 | -- Note for 'M.union': bindings in right argument shadow those in the left 70 | (@@) :: MapSubstitution -> MapSubstitution -> MapSubstitution 71 | fm1 @@ fm2 = fm1 `M.union` M.map (\t -> fm1 |-> t) fm2 72 | 73 | -- |Compose two finite map substitutions: quick and dirty! 74 | (@@@) :: MapSubstitution -> MapSubstitution -> MapSubstitution 75 | (@@@) = M.union 76 | 77 | singleSubstitution :: Tm.Nom -> Tm.VAL -> MapSubstitution 78 | singleSubstitution = M.singleton 79 | 80 | listToSubstitution :: [(Tm.Nom,Tm.VAL)] -> MapSubstitution 81 | listToSubstitution = M.fromList 82 | 83 | -- |A fixpoint is computed when looking up the target of a type variable in this substitution. 84 | -- Combining two substitutions is cheap, whereas a lookup is more expensive than the 85 | -- normal finite map substitution. 86 | newtype FixpointSubstitution = FixpointSubstitution (M.Map Tm.Nom Tm.VAL) 87 | 88 | instance Substitution FixpointSubstitution where 89 | lookupInt i original@(FixpointSubstitution fm) = 90 | case M.lookup i fm of 91 | Just tp | tp == Tm.var i -> Tm.var i 92 | | otherwise -> original |-> tp 93 | Nothing -> Tm.var i 94 | removeDom is (FixpointSubstitution fm) = FixpointSubstitution (M.filterWithKey (\i _ -> i `notElem` is) fm) 95 | restrictDom is (FixpointSubstitution fm) = let js = M.keys fm \\ is 96 | in FixpointSubstitution (M.filterWithKey (\i _ -> i `notElem` js) fm) 97 | dom (FixpointSubstitution fm) = M.keys fm 98 | cod (FixpointSubstitution fm) = M.elems fm 99 | 100 | -- |The empty fixpoint substitution 101 | emptyFPS :: FixpointSubstitution 102 | emptyFPS = FixpointSubstitution M.empty 103 | 104 | -- |Combine two fixpoint substitutions that are disjoint 105 | disjointFPS :: FixpointSubstitution -> FixpointSubstitution -> FixpointSubstitution 106 | disjointFPS (FixpointSubstitution fm1) (FixpointSubstitution fm2) = 107 | let notDisjoint = internalError "Substitution" "disjointFPS" "the two fixpoint substitutions are not disjoint" 108 | in FixpointSubstitution (M.unionWith notDisjoint fm1 fm2) 109 | 110 | ---------------------------------------------------------------------- 111 | -- * Wrapper for substitutions 112 | 113 | wrapSubstitution :: Substitution substitution => substitution -> WrappedSubstitution 114 | wrapSubstitution substitution = 115 | WrappedSubstitution substitution 116 | ( lookupInt 117 | , removeDom 118 | , restrictDom 119 | , dom 120 | , cod 121 | ) 122 | 123 | data WrappedSubstitution = 124 | forall a . Substitution a => 125 | WrappedSubstitution a 126 | ( Tm.Nom -> a -> Tm.VAL 127 | , [Tm.Nom] -> a -> a 128 | , [Tm.Nom] -> a -> a 129 | , a -> [Tm.Nom] 130 | , a -> [Tm.VAL] 131 | ) 132 | 133 | instance Substitution WrappedSubstitution where 134 | lookupInt i (WrappedSubstitution x (f,_,_,_,_)) = f i x 135 | removeDom is (WrappedSubstitution x (_,f,_,_,_)) = wrapSubstitution (f is x) 136 | restrictDom is (WrappedSubstitution x (_,_,f,_,_)) = wrapSubstitution (f is x) 137 | dom (WrappedSubstitution x (_,_,_,f,_)) = f x 138 | cod (WrappedSubstitution x (_,_,_,_,f)) = f x 139 | 140 | ---------------------------------------------------------------------- 141 | -- * Substitutables instances 142 | 143 | instance Substitutable Tm.VAL where 144 | sub |-> tp = 145 | error "sub" 146 | ftv tp = 147 | error "ftv" 148 | 149 | instance Substitutable a => Substitutable [a] where 150 | sub |-> as = map (sub |->) as 151 | ftv = foldr (union . ftv) [] 152 | 153 | instance (Substitutable a, Substitutable b) => Substitutable (a, b) where 154 | sub |-> (a, b) = (sub |-> a, sub |-> b) 155 | ftv (a, b) = ftv a `union` ftv b 156 | 157 | instance Substitutable a => Substitutable (Maybe a) where 158 | sub |-> ma = fmap (sub |->) ma 159 | ftv = maybe [] ftv 160 | 161 | instance (Substitutable a, Substitutable b) => Substitutable (Either a b) where 162 | sub |-> x = either (Left . (sub |->)) (Right . (sub |->)) x 163 | ftv = either ftv ftv 164 | 165 | freezeFTV :: Substitutable a => a -> a 166 | freezeFTV a = 167 | let sub = listToSubstitution [ (i, error "freeze" ('_':show i)) | i <- ftv a ] 168 | in sub |-> a 169 | 170 | allTypeVariables :: HasTypes a => a -> [Tm.Nom] 171 | allTypeVariables = ftv . getTypes 172 | 173 | allTypeConstants :: HasTypes a => a -> [String] 174 | allTypeConstants = 175 | let f = error "allTypeConstants" 176 | -- let f (TVar _) = [] 177 | -- f (TCon s) = [s] 178 | -- f (TApp l r) = f l ++ f r 179 | in nub . concatMap f . getTypes 180 | -------------------------------------------------------------------------------- /src/Top/Types/Synonym.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | -- 8 | -- This module contains type synonyms to represent type synonyms. A collection 9 | -- of type synonyms can always be ordered, since (mutually) recursive type 10 | -- synonyms are not permitted. The ordering of type synonyms must be determined 11 | -- to find a minimal number of unfold steps to make two types syntactically 12 | -- equivalent. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Top.Types.Synonym () where 17 | 18 | import Data.Graph (buildG, scc) 19 | import qualified Data.Map as M 20 | import Data.Maybe 21 | import Data.Tree (flatten) 22 | import Top.Types.Primitive 23 | import Top.Types.Substitution hiding (lookupInt) 24 | import Utils (internalError) 25 | {- 26 | ---------------------------------------------------------------------- 27 | -- * Type synonyms 28 | 29 | -- |A (unordered) collection of type synonyms is represented by a finite map of 30 | -- strings (the name of the type synonym) to pairs that have an int 31 | -- (the number of arguments of the type synonym) and a function. 32 | type TypeSynonyms = M.Map String (Int, Tps -> Tp) 33 | -- |An ordering of type synonyms maps a name of a type synonym to 34 | -- a position in the ordering. 35 | type TypeSynonymOrdering = M.Map String Int 36 | -- |An (unordered) collection of type synonyms, together with an ordering. 37 | type OrderedTypeSynonyms = (TypeSynonymOrdering, TypeSynonyms) 38 | 39 | ---------------------------------------------------------------------- 40 | -- * Utility functions 41 | 42 | -- |An empty collection of ordered type synonyms. 43 | noOrderedTypeSynonyms :: OrderedTypeSynonyms 44 | noOrderedTypeSynonyms = (M.empty, M.empty) 45 | 46 | -- |A string is a list of characters 47 | stringAsTypeSynonym :: OrderedTypeSynonyms 48 | stringAsTypeSynonym = (M.singleton "String" 0, M.singleton "String" (0, \_ -> listType charType)) 49 | 50 | -- |Order a collection of type synonyms, and return this ordering paired with 51 | -- sets of mutually recursive type synonyms that are detected. 52 | getTypeSynonymOrdering :: TypeSynonyms -> (TypeSynonymOrdering, [[String]]) 53 | getTypeSynonymOrdering synonyms = 54 | let 55 | (nameTable, intTable) = let keys = M.keys synonyms 56 | in ( M.fromList (zip keys [0..]) 57 | , M.fromList (zip [0..] keys) 58 | ) 59 | 60 | err = internalError "Top.Types.Synonyms" "getTypeSynonymOrdering" "error in lookup table" 61 | lookupName n = fromMaybe err (M.lookup n nameTable) 62 | lookupInt i = fromMaybe err (M.lookup i intTable) 63 | 64 | edges = let op s1 (arity, function) es = 65 | let i1 = lookupName s1 66 | cs = constantsInType (function (map TVar [0 .. arity - 1])) 67 | add s2 = case M.lookup s2 nameTable of 68 | Just i2 -> (:) (i2,i1) 69 | Nothing -> id 70 | in foldr add es cs 71 | in M.foldrWithKey op [] synonyms 72 | 73 | graph = buildG (0, M.size synonyms - 1) edges 74 | list = map flatten (scc graph) 75 | 76 | (ordering, recursive, _) = 77 | let op ints (os, rs, counter) = 78 | case ints of 79 | [int] | (int, int) `notElem` edges -- correct type synonym 80 | -> (M.insert (lookupInt int) counter os, rs, counter + 1) 81 | _ -> (os, map lookupInt ints : rs, counter) 82 | in foldr op (M.empty, [], 0) list 83 | in 84 | (ordering, recursive) 85 | 86 | isPhantomTypeSynonym :: OrderedTypeSynonyms -> String -> Bool 87 | isPhantomTypeSynonym (_, xs) s = 88 | case M.lookup s xs of 89 | Nothing -> False 90 | Just (i, f) -> 91 | let is = take i [0..] 92 | tp = f (map TVar is) 93 | free = ftv tp 94 | in any (`notElem` free) is 95 | 96 | ---------------------------------------------------------------------- 97 | -- * Expansion of a type 98 | 99 | -- |Fully expand a type in a recursive way. 100 | expandType :: TypeSynonyms -> Tp -> Tp 101 | expandType synonyms tp = 102 | let (x,xs) = leftSpine (expandTypeConstructor synonyms tp) 103 | in foldl TApp x (map (expandType synonyms) xs) 104 | 105 | -- |Fully expand the top-level type constructor. 106 | expandTypeConstructor :: TypeSynonyms -> Tp -> Tp 107 | expandTypeConstructor synonyms tp = 108 | maybe tp (expandTypeConstructor synonyms) (expandTypeConstructorOneStep synonyms tp) 109 | 110 | -- |Fully expand the top-level type constructor. 111 | expandToplevelTC :: OrderedTypeSynonyms -> Tp -> Maybe Tp 112 | expandToplevelTC (_, synonyms) = 113 | fmap (expandTypeConstructor synonyms) . expandTypeConstructorOneStep synonyms 114 | 115 | -- |Try to expand the top-level type constructor one step. 116 | expandTypeConstructorOneStep :: TypeSynonyms -> Tp -> Maybe Tp 117 | expandTypeConstructorOneStep synonyms tp = 118 | case leftSpine tp of 119 | (TCon s, tps) -> case M.lookup s synonyms of 120 | Just (i, f) | i == length tps -> Just (f tps) 121 | | otherwise -> internalError "Top.Types.Synonyms" 122 | "expandTypeConstructorOneStep" 123 | "invalid arity of type synonym" 124 | Nothing -> Nothing 125 | _ -> Nothing 126 | 127 | -- |Try to expand the top-level type constructor of one of the two paired Top.Types. If both 128 | -- top-level type constructors can be expanded, then the type synonym thast appears first 129 | -- in the ordering is expanded. 130 | expandOneStepOrdered :: OrderedTypeSynonyms -> (Tp, Tp) -> Maybe (Tp, Tp) 131 | expandOneStepOrdered (ordering, synonyms) (t1,t2) = 132 | let f tp = case fst (leftSpine tp) of 133 | TCon s -> M.lookup s ordering 134 | _ -> Nothing 135 | expand tp = fromMaybe err (expandTypeConstructorOneStep synonyms tp) 136 | err = internalError "Top.Types.Synonyms" "expandOneStep" "invalid set of OrderedTypeSynonyms" 137 | in case (f t1, f t2) of 138 | (Just i1, Just i2) | i1 <= i2 -> Just (expand t1, t2) 139 | | otherwise -> Just (t1, expand t2) 140 | (Just _ , Nothing) -> Just (expand t1, t2) 141 | (Nothing, Just _ ) -> Just (t1, expand t2) 142 | _ -> Nothing 143 | 144 | -} 145 | -------------------------------------------------------------------------------- /src/Top/Types/Unification.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | -- 8 | -- A unification algorithm for types, which can take a list of (ordered) 9 | -- type synonyms into account. 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Top.Types.Unification where 14 | 15 | import qualified Data.Map as M 16 | import Top.Types.Primitive 17 | import Top.Types.Substitution 18 | import Top.Types.Synonym 19 | import Utils (internalError) 20 | 21 | import qualified PatternUnify.Tm as Tm 22 | 23 | import qualified Unbound.Generics.LocallyNameless as Ln 24 | 25 | import Debug.Trace (trace) 26 | 27 | {- 28 | -- |There are two reasons why two types cannot be unified: either two (different) type constants clash (they 29 | -- should be the same), or a type variable should be unified with a composed type that contains this same 30 | -- type variable. 31 | data UnificationError 32 | = ConstantClash String String 33 | | InfiniteType Int 34 | deriving (Show,Eq) 35 | 36 | -- |The most general unification (substitution) of two types. 37 | mgu :: Tp -> Tp -> Either UnificationError MapSubstitution 38 | mgu t1 t2 = 39 | case mguWithTypeSynonyms noOrderedTypeSynonyms t1 t2 of 40 | Left uError -> Left uError 41 | Right (_, s) -> Right s 42 | 43 | -- Expand type synonyms as lazy as possible 44 | -- example: 45 | -- if String => [Char] 46 | -- then v11 -> [v11] `mgu` String -> [[v14]] 47 | -- should be: 48 | -- [ v11 := [Char] , v14 := Char ] 49 | -- 50 | -- Note: the boolean indicates whether exansions were necessary 51 | mguWithTypeSynonyms :: OrderedTypeSynonyms -> Tp -> Tp -> Either UnificationError (Bool, MapSubstitution) 52 | mguWithTypeSynonyms typesynonyms = rec emptySubst 53 | 54 | where 55 | rec sub t1 t2 = 56 | case (leftSpine t1, leftSpine t2) of 57 | ((TVar i,[]), _) -> recVar sub i t2 58 | (_, (TVar i,[])) -> recVar sub i t1 59 | ((TCon s, ss), (TCon t, tt)) 60 | | s == t && not (isPhantomTypeSynonym typesynonyms s) -> 61 | recList sub ss tt 62 | | otherwise -> 63 | case expandOneStepOrdered typesynonyms (t1, t2) of 64 | Just (t1', t2') -> 65 | case rec sub t1' t2' of 66 | Left uError -> Left uError 67 | Right (_, sub') -> Right (True, sub') 68 | Nothing -> Left (ConstantClash s t) 69 | 70 | _ -> case (t1, t2) of 71 | (TApp l1 r1, TApp l2 r2) -> recList sub [l1, r1] [l2, r2] 72 | _ -> internalError "Top.Types.Unification" "mguWithTypeSynonyms" "illegal type" 73 | 74 | recVar sub i tp = 75 | case M.lookup i sub of 76 | Just t2 -> 77 | case rec sub tp t2 of 78 | Right (True,sub') -> 79 | let mtp = equalUnderTypeSynonyms typesynonyms (sub' |-> tp) (sub' |-> t2) 80 | in case mtp of 81 | Just newTP -> Right (True,singleSubstitution i newTP @@ removeDom [i] sub') 82 | Nothing -> internalError "Top.Types.Unification" "mguWithTypeSynonyms" "illegal types" 83 | answer -> answer 84 | Nothing -> 85 | case sub |-> tp of 86 | TVar j | i == j -> Right (False, sub) 87 | tp' | i `elem` ftv tp' -> Left (InfiniteType i) 88 | | otherwise -> Right (False, singleSubstitution i tp' @@ sub) 89 | 90 | recList sub [] [] = Right (False,sub) 91 | recList sub (s:ss) (t:tt) = 92 | case rec sub s t of 93 | Left uError -> Left uError 94 | Right (b,sub') -> 95 | case recList sub' ss tt of 96 | Left uError -> Left uError 97 | Right (b',sub'') -> Right (b || b', sub'') 98 | recList _ _ _ = 99 | internalError "Top.Types.Unification" "mguWithTypeSynonyms" "kinds do not match" 100 | 101 | -- |Find the most general type for two types that are equal under type synonyms 102 | -- (i.e., the least number of expansions) 103 | equalUnderTypeSynonyms :: OrderedTypeSynonyms -> Tp -> Tp -> Maybe Tp 104 | equalUnderTypeSynonyms typesynonyms t1 t2 = 105 | case (leftSpine t1,leftSpine t2) of 106 | ((TVar i,[]),(TVar _,[])) -> Just (TVar i) 107 | ((TCon s,ss),(TCon t,tt)) 108 | | s == t && not (isPhantomTypeSynonym typesynonyms s) -> 109 | do let f = uncurry (equalUnderTypeSynonyms typesynonyms) 110 | xs <- mapM f (zip ss tt) 111 | Just (foldl TApp (TCon s) xs) 112 | | otherwise -> 113 | do (t1', t2') <- expandOneStepOrdered typesynonyms (t1, t2) 114 | equalUnderTypeSynonyms typesynonyms t1' t2' 115 | 116 | _ -> Nothing 117 | 118 | -- |Given a set of (ordered) type synonyms, can two types be unified? 119 | unifiable :: OrderedTypeSynonyms -> Tp -> Tp -> Bool 120 | unifiable typesynonyms t1 t2 = 121 | case mguWithTypeSynonyms typesynonyms t1 t2 of 122 | Left _ -> False 123 | Right _ -> True 124 | 125 | -- |Same as unifiable, but takes as input a list of types 126 | unifiableList :: OrderedTypeSynonyms -> Tps -> Bool 127 | unifiableList typesynonyms (t1:t2:ts) = 128 | case mguWithTypeSynonyms typesynonyms t1 t2 of 129 | Left _ -> False 130 | Right (_, sub) -> unifiableList typesynonyms (sub |-> (t2:ts)) 131 | unifiableList _ _ = True 132 | 133 | -} 134 | 135 | -- |Find the most general type for two types that are equal under type synonyms 136 | -- (i.e., the least number of expansions) 137 | firstOrderUnify :: Tm.VAL -> Tm.VAL -> Maybe Tm.VAL 138 | firstOrderUnify t1 t2 = 139 | case unifyToList t1 t2 of 140 | [x] -> Just x 141 | _ -> Nothing 142 | 143 | isMetaNeutral (Tm.N (Tm.Meta _ ) (_:_)) = True 144 | isMetaNeutral _ = False 145 | 146 | unifyToList :: Tm.VAL -> Tm.VAL -> [Tm.VAL] 147 | unifyToList t1 t2 = 148 | case (t1,t2) of 149 | --Variables unify with anything 150 | ((Tm.N (Tm.Meta i) []), x) -> [x] 151 | ((x, Tm.N (Tm.Meta i) [])) -> [x] 152 | --TODO don't assume functions ignore arguments? 153 | (e1@(Tm.L _), e2@(Tm.L _)) -> do 154 | let 155 | (x, body1, body2) = Ln.runFreshM $ do 156 | xm <- Ln.fresh $ Ln.s2n "foUnif__" 157 | body1m <- e1 Tm.$$ Tm.var x 158 | body2m <- e2 Tm.$$ Tm.var x 159 | return (xm, body1m, body2m) 160 | bodyRet <- unifyToList body1 body2 161 | return $ Tm.L $ Ln.bind x bodyRet 162 | 163 | 164 | ((Tm.C s ss),(Tm.C t tt)) 165 | | s == t -> 166 | do let f = uncurry unifyToList 167 | xs <- mapM f (zip ss tt) 168 | return $ Tm.C s xs 169 | 170 | _ -> case (t1 == t2) of 171 | True -> return t1 172 | False -> filter (not . isMetaNeutral) [t1, t2] 173 | -------------------------------------------------------------------------------- /src/Top/Util/Embedding.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | ----------------------------------------------------------------------------- 8 | 9 | module Top.Util.Embedding where 10 | 11 | data Embedding a b = Embedding { getE :: a -> b, changeE :: (b -> b) -> a -> a } 12 | 13 | setE :: Embedding a b -> b -> a -> a 14 | setE e = changeE e . const 15 | 16 | withE :: Embedding a b -> (b -> c) -> a -> c 17 | withE e f = f . getE e 18 | 19 | ------------------------------ 20 | -- useful embeddings 21 | 22 | idE :: Embedding a a 23 | idE = Embedding { getE = id, changeE = id } 24 | 25 | fstE :: Embedding (a, b) a 26 | fstE = Embedding { getE = fst, changeE = \f (a, b) -> (f a, b) } 27 | 28 | sndE :: Embedding (a, b) b 29 | sndE = Embedding { getE = snd, changeE = \f (a, b) -> (a, f b) } 30 | 31 | ------------------------------ 32 | -- compositions of embeddings 33 | 34 | composeE :: Embedding a b -> Embedding b c -> Embedding a c 35 | composeE e1 e2 = Embedding { getE = getE e2 . getE e1, changeE = changeE e1 . changeE e2 } 36 | 37 | fromFstE :: Embedding a c -> Embedding (a, b) c 38 | fromFstE = composeE fstE 39 | 40 | fromSndE :: Embedding b c -> Embedding (a, b) c 41 | fromSndE = composeE sndE -------------------------------------------------------------------------------- /src/Top/Util/Empty.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | ----------------------------------------------------------------------------- 8 | 9 | module Top.Util.Empty where 10 | 11 | ------------------------------------------------------------------------ 12 | -- * Empty type class 13 | 14 | class Empty a where 15 | empty :: a 16 | 17 | instance Empty () where 18 | empty = () 19 | 20 | instance (Empty a, Empty b) => Empty (a, b) where 21 | empty = (empty, empty) 22 | 23 | instance Empty [a] where 24 | empty = [] 25 | 26 | instance Empty (Maybe a) where 27 | empty = Nothing 28 | 29 | instance Empty a => Empty (Either a b) where 30 | empty = Left empty -------------------------------------------------------------------------------- /src/Top/Util/Option.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | ----------------------------------------------------------------------------- 3 | -- | License : GPL 4 | -- 5 | -- Maintainer : helium@cs.uu.nl 6 | -- Stability : provisional 7 | -- Portability : non-portable (requires extensions) 8 | ----------------------------------------------------------------------------- 9 | 10 | module Top.Util.Option where 11 | 12 | import Control.Monad.State 13 | 14 | option :: a -> String -> Option a 15 | option a s = Option { defaultValue = a, currentValue = a, optionDescription = s } 16 | 17 | data Option a = Option { defaultValue :: a, currentValue :: a, optionDescription :: String } 18 | data OptionAccess m a = Access { getOption :: m a, setOption :: a -> m () } 19 | 20 | ignoreOption :: Monad m => Option a -> OptionAccess m a 21 | ignoreOption value = 22 | Access { getOption = return (currentValue value), setOption = const $ return () } 23 | 24 | optionAccessTrans :: (forall a . m1 a -> m2 a) -> OptionAccess m1 b -> OptionAccess m2 b 25 | optionAccessTrans f oa = 26 | Access { getOption = f (getOption oa), setOption = f . setOption oa } 27 | 28 | useOption :: MonadState s m => (s -> Option a) -> (Option a -> s -> s) -> OptionAccess m a 29 | useOption getter setter = 30 | let f b x = setter ((getter x) { currentValue = b }) x 31 | in Access { getOption = gets (currentValue . getter), setOption = modify . f } 32 | 33 | instance (Show a, Eq a) => Show (Option a) where 34 | show a = 35 | let extra | currentValue a == defaultValue a = " (default)" 36 | | otherwise = "" 37 | in optionDescription a ++ ": " ++ show (currentValue a) ++ extra 38 | 39 | instance Functor Option where 40 | fmap f a = a { defaultValue = f (defaultValue a), currentValue = f (currentValue a) } -------------------------------------------------------------------------------- /src/Utils.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | License : GPL 3 | -- 4 | -- Maintainer : helium@cs.uu.nl 5 | -- Stability : provisional 6 | -- Portability : portable 7 | ----------------------------------------------------------------------------- 8 | 9 | module Utils (internalError) where 10 | 11 | internalError :: String -> String -> String -> a 12 | internalError moduleName functionName message = 13 | error . unlines $ 14 | [ "" 15 | , "INTERNAL ERROR - " ++ message 16 | , "** Module : " ++ moduleName 17 | , "** Function : " ++ functionName 18 | ] 19 | -------------------------------------------------------------------------------- /thesisExamples/AgdaPrelude.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module AgdaPrelude where 3 | 4 | data Nat : Set where 5 | Zero : Nat 6 | Succ : Nat -> Nat 7 | 8 | natElim : (m : Nat -> Set) -> (mz : m Zero) -> (ms : (l : Nat) -> m l -> m (Succ l)) -> (k : Nat) -> m k 9 | natElim m mz ms Zero = mz 10 | natElim m mz ms (Succ k) = ms k (natElim m mz ms k) 11 | 12 | data Vec : Set -> Nat -> Set where 13 | Nil : (a : Set) -> Vec a Zero 14 | Cons : (a : Set) -> (n : Nat) -> (x : a) -> (xs : Vec a n) -> Vec a (Succ n) 15 | 16 | data Eq : (a : Set) -> a -> a -> Set where 17 | Refl : (a : Set) -> (x : a) -> Eq a x x 18 | -------------------------------------------------------------------------------- /thesisExamples/AgdaPrelude.agdai: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/JoeyEremondi/lambda-pi-constraint/45e3a6fe2d44e0fa53e6ec464d930ed358974b5a/thesisExamples/AgdaPrelude.agdai -------------------------------------------------------------------------------- /thesisExamples/ArgsWrongOrder.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module ArgsWrongOrder where 3 | 4 | open import AgdaPrelude 5 | 6 | myFun : (a : Set) -> a -> Nat -> Nat 7 | myFun _ x y = y 8 | 9 | myApp = myFun _ Zero (Nil Nat) 10 | -------------------------------------------------------------------------------- /thesisExamples/ArgsWrongOrder.agdai: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/JoeyEremondi/lambda-pi-constraint/45e3a6fe2d44e0fa53e6ec464d930ed358974b5a/thesisExamples/ArgsWrongOrder.agdai -------------------------------------------------------------------------------- /thesisExamples/ArgsWrongOrder.idr: -------------------------------------------------------------------------------- 1 | module ArgsWrongOrder 2 | 3 | import IdrisPrelude 4 | 5 | %hide Prelude.Nat.Nat 6 | 7 | 8 | myFun : (a : Type) -> a -> Nat -> Nat 9 | myFun _ x y = y 10 | 11 | myApp : Nat 12 | myApp = myFun _ Zero (IdrisPrelude.Nil Nat) 13 | -------------------------------------------------------------------------------- /thesisExamples/ArgsWrongOrder.lp: -------------------------------------------------------------------------------- 1 | let myFun = (\ _ x y -> y) :: forall (a :: *) . a -> Nat -> Nat 2 | 3 | let myApp = (myFun _ 0 (Nil Nat)) 4 | -------------------------------------------------------------------------------- /thesisExamples/BadRefl.agda: -------------------------------------------------------------------------------- 1 | module BadRefl where 2 | 3 | open import AgdaPrelude 4 | 5 | plus = 6 | natElim 7 | ( \ _ -> Nat -> Nat ) -- motive 8 | ( \ n -> n ) -- case for Zero 9 | ( \ p rec n -> Succ (rec n) ) -- case for Succ 10 | 11 | -- the other direction requires induction on N: 12 | postulate pNPlus0isN : (n : Nat) -> Eq Nat (plus n Zero) n 13 | 14 | 15 | -- the other direction requires induction on N: 16 | succPlus : (n : Nat) -> Eq Nat (Succ n) (plus (Succ n) Zero) 17 | succPlus = 18 | (\n -> pNPlus0isN (Succ n)) 19 | -------------------------------------------------------------------------------- /thesisExamples/BadRefl.agdai: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/JoeyEremondi/lambda-pi-constraint/45e3a6fe2d44e0fa53e6ec464d930ed358974b5a/thesisExamples/BadRefl.agdai -------------------------------------------------------------------------------- /thesisExamples/BadRefl.ibc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/JoeyEremondi/lambda-pi-constraint/45e3a6fe2d44e0fa53e6ec464d930ed358974b5a/thesisExamples/BadRefl.ibc -------------------------------------------------------------------------------- /thesisExamples/BadRefl.idr: -------------------------------------------------------------------------------- 1 | module BadRefl 2 | 3 | import IdrisPrelude 4 | 5 | plus : Nat -> Nat -> Nat 6 | plus = 7 | natElim 8 | ( \ _ => (Nat -> Nat) ) -- motive 9 | ( \ n => n ) -- case for Zero 10 | ( \ p, rec, n => Succ (rec n) ) -- case for Succ 11 | 12 | -- the other direction requires induction on N: 13 | postulate pNPlus0isN : (n : Nat) -> Eq Nat (plus n Zero) n 14 | 15 | 16 | -- the other direction requires induction on N: 17 | succPlus : (n : Nat) -> Eq Nat (Succ n) (plus (Succ n) Zero) 18 | succPlus = 19 | (\n => pNPlus0isN (Succ n)) 20 | -------------------------------------------------------------------------------- /thesisExamples/BadRefl.lp: -------------------------------------------------------------------------------- 1 | -- addition of natural numbers 2 | let plus = 3 | natElim 4 | ( \ _ -> Nat -> Nat ) -- motive 5 | ( \ n -> n ) -- case for Zero 6 | ( \ p rec n -> Succ (rec n) ) -- case for Succ 7 | 8 | 9 | -- Leibniz prinicple (look at the type signature) 10 | let leibniz = 11 | ( \ a b f -> eqElim a 12 | (\ x y eq_x_y -> Eq b (f x) (f y)) 13 | (\ x -> Refl b (f x)) ) 14 | :: forall (a :: *) (b :: *) (f :: a -> b) (x :: a) (y :: a) . 15 | Eq a x y -> Eq b (f x) (f y) 16 | 17 | 18 | 19 | -- the other direction requires induction on N: 20 | let pNPlus0isN = 21 | natElim ( \ n -> Eq Nat (plus n 0) n ) 22 | ( Refl Nat 0 ) 23 | ( \ n' rec -> leibniz Nat Nat Succ (plus n' 0) n' rec ) 24 | :: forall n :: Nat . Eq Nat (plus n 0) n 25 | 26 | 27 | -- the other direction requires induction on N: 28 | let succPlus = 29 | (\n -> pNPlus0isN (Succ n)) 30 | :: forall n :: Nat . Eq Nat (Succ n) (plus (Succ n) 0) 31 | -------------------------------------------------------------------------------- /thesisExamples/BadReflPost.lp: -------------------------------------------------------------------------------- 1 | -- addition of natural numbers 2 | let plus = 3 | natElim 4 | ( \ _ -> Nat -> Nat ) -- motive 5 | ( \ n -> n ) -- case for Zero 6 | ( \ p rec n -> Succ (rec n) ) -- case for Succ 7 | 8 | assume pNPlus0isN 9 | :: forall n :: Nat . Eq Nat (plus n 0) n 10 | 11 | let succPlus = 12 | (\n -> pNPlus0isN (Succ n)) 13 | :: forall n :: Nat . Eq Nat (Succ n) (plus (Succ n) 0) 14 | -------------------------------------------------------------------------------- /thesisExamples/Bias.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module Bias where 3 | 4 | open import AgdaPrelude 5 | 6 | myFun : (a : Set) -> a -> a -> a -> a 7 | myFun a x y z = x 8 | 9 | --myApp1 = myFun _ Zero Zero (Nil Nat) 10 | 11 | myApp2 = myFun _ (Nil Nat) Zero Zero 12 | -------------------------------------------------------------------------------- /thesisExamples/Bias.idr: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module Bias 3 | 4 | import IdrisPrelude 5 | 6 | myFun : (a : Type) -> a -> a -> a -> Nat 7 | myFun a x y z = Zero 8 | 9 | myApp1 : Nat 10 | myApp1 = myFun _ Zero Zero (IdrisPrelude.Nil Nat) 11 | 12 | myApp2 : Nat 13 | myApp2 = myFun _ (Nil Nat) Zero Zero 14 | -------------------------------------------------------------------------------- /thesisExamples/Bias.lp: -------------------------------------------------------------------------------- 1 | 2 | assume myFun :: forall (a :: *) . a -> a -> a -> a 3 | 4 | --let myApp1 = myFun _ Zero Zero (Nil Nat) 5 | 6 | let myApp2 = myFun _ (Nil Nat) Zero Zero 7 | -------------------------------------------------------------------------------- /thesisExamples/IdrisPrelude.ibc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/JoeyEremondi/lambda-pi-constraint/45e3a6fe2d44e0fa53e6ec464d930ed358974b5a/thesisExamples/IdrisPrelude.ibc -------------------------------------------------------------------------------- /thesisExamples/IdrisPrelude.idr: -------------------------------------------------------------------------------- 1 | module IdrisPrelude 2 | 3 | %hide Prelude.Nat.Nat 4 | 5 | 6 | data Nat : Type where 7 | Zero : Nat 8 | Succ : Nat -> Nat 9 | 10 | natElim : (m : Nat -> Type) -> (mz : m Zero) -> (ms : (l : Nat) -> m l -> m (Succ l)) -> (k : Nat) -> m k 11 | natElim m mz ms Zero = mz 12 | natElim m mz ms (Succ k) = ms k (natElim m mz ms k) 13 | 14 | data Vec : Type -> Nat -> Type where 15 | Nil : (a : Type) -> Vec a Zero 16 | Cons : (a : Type) -> (n : Nat) -> (x : a) -> (xs : Vec a n) -> Vec a (Succ n) 17 | 18 | data Eq : (a : Type) -> a -> a -> Type where 19 | Refl : (a : Type) -> (x : a) -> Eq a x x 20 | -------------------------------------------------------------------------------- /thesisExamples/PlusReverse.lp: -------------------------------------------------------------------------------- 1 | -- addition of natural numbers 2 | let plus = (\ y x -> 3 | (natElim 4 | ( \ _ -> Nat -> Nat ) -- motive 5 | ( \ n -> n ) -- case for Zero 6 | ( \ p rec n -> Succ (rec n) ) -- case for Succ 7 | ) x y ) :: Nat -> Nat -> Nat 8 | 9 | let p0PlusNisN = 10 | (\ x -> 11 | Refl Nat x 12 | ) 13 | :: (forall (n :: Nat) . Eq Nat (plus 0 n) n) 14 | -------------------------------------------------------------------------------- /thesisExamples/TooFewArgs.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module TooFewArgs where 3 | 4 | open import AgdaPrelude 5 | 6 | myFun : (a : Set) -> a -> a -> a 7 | myFun a x y = x 8 | 9 | myApp : Nat 10 | myApp = myFun _ Zero 11 | -------------------------------------------------------------------------------- /thesisExamples/TooFewArgs.ibc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/JoeyEremondi/lambda-pi-constraint/45e3a6fe2d44e0fa53e6ec464d930ed358974b5a/thesisExamples/TooFewArgs.ibc -------------------------------------------------------------------------------- /thesisExamples/TooFewArgs.idr: -------------------------------------------------------------------------------- 1 | module TooFewArgs 2 | 3 | import IdrisPrelude 4 | 5 | myFun : (a : Type) -> a -> a -> a 6 | myFun a x y = x 7 | 8 | myApp : Nat 9 | myApp = myFun _ Zero 10 | -------------------------------------------------------------------------------- /thesisExamples/TooFewArgs.lp: -------------------------------------------------------------------------------- 1 | let myFun = (\ x y -> x) :: Nat -> Nat -> Nat 2 | 3 | let myApp = (myFun 0) :: Nat 4 | -------------------------------------------------------------------------------- /thesisExamples/TooFewArgsWrongType.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module TooFewArgsWrongType where 3 | 4 | open import AgdaPrelude 5 | 6 | myFun : Vec Nat Zero -> Nat -> Nat 7 | myFun x y = y 8 | 9 | myApp : Nat 10 | myApp = (myFun Zero) 11 | -------------------------------------------------------------------------------- /thesisExamples/TooFewArgsWrongType.lp: -------------------------------------------------------------------------------- 1 | let myFun = (\ x y -> y) :: Vec Nat 0 -> Nat -> Nat 2 | 3 | let myApp = (myFun 0) :: Nat 4 | -------------------------------------------------------------------------------- /thesisExamples/TooManyArgs.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module TooManyArgs where 3 | 4 | open import AgdaPrelude 5 | 6 | myFun : (a : Set) -> a -> a -> a 7 | myFun a x y = x 8 | 9 | myApp = myFun _ Zero Zero Zero Zero 10 | -------------------------------------------------------------------------------- /thesisExamples/TooManyArgs.idr: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module TooManyArgs 3 | 4 | import IdrisPrelude 5 | 6 | myFun : (a : Type) -> a -> a -> a 7 | myFun a x y = x 8 | 9 | myApp : Nat 10 | myApp = myFun _ Zero Zero Zero Zero 11 | -------------------------------------------------------------------------------- /thesisExamples/TooManyArgs.lp: -------------------------------------------------------------------------------- 1 | let myFun = (\ a x y -> x) :: forall (a :: *) . a -> a -> a 2 | 3 | let myApp = myFun _ 0 1 2 4 | -------------------------------------------------------------------------------- /thesisExamples/VecFlip.agda: -------------------------------------------------------------------------------- 1 | module VecFlip where 2 | 3 | open import AgdaPrelude 4 | 5 | 6 | goodNil : Vec Nat Zero 7 | goodNil = Nil Nat 8 | 9 | badNil : Vec Zero Nat 10 | badNil = Nil Nat 11 | -------------------------------------------------------------------------------- /thesisExamples/VecFlip.lp: -------------------------------------------------------------------------------- 1 | let badNil = Nil Nat :: Vec 0 Nat 2 | --------------------------------------------------------------------------------