├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── SimpleFP-v2.cabal └── src ├── Continuations ├── Core │ ├── ConSig.hs │ ├── DeclArg.hs │ ├── Decontinuization.hs │ ├── Evaluation.hs │ ├── Parser.hs │ ├── Program.hs │ └── Term.hs ├── Demo.sfp └── Unification │ ├── Elaboration.hs │ ├── Elaborator.hs │ ├── REPL.hs │ ├── TypeChecking.hs │ └── Unification.hs ├── Dependent ├── Core │ ├── ConSig.hs │ ├── DeclArg.hs │ ├── Evaluation.hs │ ├── Parser.hs │ ├── Program.hs │ └── Term.hs ├── Demo.sfp ├── Monadic │ ├── Elaboration.hs │ ├── Elaborator.hs │ ├── Equality.hs │ ├── REPL.hs │ └── TypeChecking.hs └── Unification │ ├── Elaboration.hs │ ├── Elaborator.hs │ ├── REPL.hs │ ├── TypeChecking.hs │ └── Unification.hs ├── DependentImplicit ├── Core │ ├── ConSig.hs │ ├── DeclArg.hs │ ├── Evaluation.hs │ ├── Parser.hs │ ├── Program.hs │ └── Term.hs ├── Demo.sfp └── Unification │ ├── Elaboration.hs │ ├── Elaborator.hs │ ├── REPL.hs │ ├── TypeChecking.hs │ └── Unification.hs ├── Modular ├── Core │ ├── ConSig.hs │ ├── DeclArg.hs │ ├── Evaluation.hs │ ├── Parser.hs │ ├── Program.hs │ └── Term.hs ├── Demo.sfp └── Unification │ ├── Elaboration.hs │ ├── Elaborator.hs │ ├── REPL.hs │ ├── TypeChecking.hs │ └── Unification.hs ├── OpenDefs ├── Core │ ├── ConSig.hs │ ├── DeclArg.hs │ ├── Evaluation.hs │ ├── Parser.hs │ ├── Program.hs │ └── Term.hs ├── Demo.sfp └── Unification │ ├── Elaboration.hs │ ├── Elaborator.hs │ ├── REPL.hs │ ├── TypeChecking.hs │ └── Unification.hs ├── Poly ├── Core │ ├── ConSig.hs │ ├── Evaluation.hs │ ├── Parser.hs │ ├── Program.hs │ ├── Term.hs │ └── Type.hs ├── Demo.sfp └── Unification │ ├── Elaboration.hs │ ├── Elaborator.hs │ ├── REPL.hs │ ├── TypeChecking.hs │ └── Unification.hs ├── Quasiquote ├── Core │ ├── ConSig.hs │ ├── DeclArg.hs │ ├── Evaluation.hs │ ├── Parser.hs │ ├── Program.hs │ └── Term.hs ├── Demo.sfp └── Unification │ ├── Elaboration.hs │ ├── Elaborator.hs │ ├── REPL.hs │ ├── TypeChecking.hs │ └── Unification.hs ├── Record ├── Core │ ├── ConSig.hs │ ├── DeclArg.hs │ ├── Evaluation.hs │ ├── Parser.hs │ ├── Program.hs │ └── Term.hs ├── Demo.sfp └── Unification │ ├── Elaboration.hs │ ├── Elaborator.hs │ ├── REPL.hs │ ├── TypeChecking.hs │ └── Unification.hs ├── Require ├── Core │ ├── ConSig.hs │ ├── DeclArg.hs │ ├── Decontinuization.hs │ ├── Evaluation.hs │ ├── Parser.hs │ ├── Program.hs │ ├── RequireSolving.hs │ └── Term.hs ├── Demo.sfp └── Unification │ ├── Elaboration.hs │ ├── Elaborator.hs │ ├── REPL.hs │ ├── TypeChecking.hs │ └── Unification.hs ├── Simple ├── Core │ ├── ConSig.hs │ ├── Evaluation.hs │ ├── Parser.hs │ ├── Program.hs │ ├── Term.hs │ └── Type.hs ├── Demo.sfp ├── Monadic │ ├── Elaboration.hs │ ├── Elaborator.hs │ ├── Equality.hs │ ├── REPL.hs │ └── TypeChecking.hs └── Unification │ ├── Elaboration.hs │ ├── Elaborator.hs │ ├── REPL.hs │ ├── TypeChecking.hs │ └── Unification.hs └── Utils ├── ABT.hs ├── ABTExamples.hs ├── Elaborator.hs ├── Env.hs ├── Eval.hs ├── Names.hs ├── Plicity.hs ├── Pretty.hs ├── Telescope.hs ├── Unifier.hs └── Vars.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virtualenv 8 | .hsenv 9 | .cabal-sandbox/ 10 | cabal.sandbox.config 11 | cabal.config 12 | TAGS 13 | .DS_Store 14 | *~ 15 | *# -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Darryl McAdams 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /SimpleFP-v2.cabal: -------------------------------------------------------------------------------- 1 | -- Initial SimpleFP-v2.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: SimpleFP-v2 5 | version: 0.1.0.0 6 | synopsis: A series of implementations of typed functional programming languages. 7 | -- description: 8 | -- license: 9 | license-file: LICENSE 10 | author: Darryl McAdams 11 | maintainer: psygnisfive@yahoo.com 12 | -- copyright: 13 | category: Language 14 | build-type: Simple 15 | extra-source-files: README.md 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Simple.Monadic.REPL, 20 | Simple.Unification.REPL, 21 | Poly.Unification.REPL, 22 | Dependent.Monadic.REPL, 23 | Dependent.Unification.REPL, 24 | DependentImplicit.Unification.REPL, 25 | Modular.Unification.REPL, 26 | Record.Unification.REPL, 27 | OpenDefs.Unification.REPL, 28 | Quasiquote.Unification.REPL, 29 | Continuations.Unification.REPL, 30 | Require.Unification.REPL 31 | -- other-modules: 32 | -- other-extensions: 33 | build-depends: base, 34 | bifunctors, 35 | containers, 36 | lens, 37 | mtl, 38 | parsec, 39 | transformers 40 | hs-source-dirs: src 41 | default-language: Haskell2010 -------------------------------------------------------------------------------- /src/Continuations/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | module Continuations.Core.ConSig where 10 | 11 | import Utils.ABT 12 | import Utils.Names 13 | import Utils.Plicity 14 | import Utils.Pretty (pretty) 15 | import Utils.Telescope 16 | import Continuations.Core.DeclArg 17 | import Continuations.Core.Term 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | data ConSig = ConSig [Plicity] (BindingTelescope (Scope TermF)) 26 | 27 | 28 | instance Show ConSig where 29 | show (ConSig plics (BindingTelescope ascs bsc)) = 30 | binders ++ " " ++ pretty (body bsc) 31 | where 32 | binders = 33 | unwords 34 | (zipWith 35 | (\n (plic,a) -> wrap plic (n ++ " : " ++ a)) 36 | ns 37 | (zip plics as)) 38 | as = map (pretty.body) ascs 39 | ns = names bsc 40 | 41 | wrap Expl x = "(" ++ x ++ ")" 42 | wrap Impl x = "{" ++ x ++ "}" 43 | 44 | 45 | conSigH :: [DeclArg] -> Term -> ConSig 46 | conSigH declas b = ConSig plics (bindingTelescopeH xs as b) 47 | where (plics,xas) = unzip [ (plic,(x,a)) | DeclArg plic x a <- declas ] 48 | (xs,as) = unzip xas 49 | 50 | 51 | freeToDefinedConSig :: ConSig -> ConSig 52 | freeToDefinedConSig (ConSig plics tele) = 53 | ConSig plics (fmap (freeToDefinedScope (In . Defined . BareLocal)) tele) -------------------------------------------------------------------------------- /src/Continuations/Core/DeclArg.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | module Continuations.Core.DeclArg where 6 | 7 | import Utils.Plicity 8 | import Utils.Pretty 9 | import Continuations.Core.Term 10 | 11 | 12 | 13 | data DeclArg = DeclArg Plicity String Term 14 | 15 | instance Show DeclArg where 16 | show (DeclArg Expl x t) = "(" ++ x ++ " : " ++ pretty t ++ ")" 17 | show (DeclArg Impl x t) = "{" ++ x ++ " : " ++ pretty t ++ "}" -------------------------------------------------------------------------------- /src/Continuations/Core/Decontinuization.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module defines the tools for decontinuizing terms. 10 | 11 | module Continuations.Core.Decontinuization where 12 | 13 | import Utils.ABT hiding (shift) 14 | import Utils.Vars 15 | import Continuations.Core.Term 16 | 17 | import Control.Monad.Reader 18 | import Control.Monad.State 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | -- | Binary composition to make applicative style more convenient. 28 | 29 | (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d 30 | f .: g = \x y -> f (g x y) 31 | 32 | 33 | -- | Trinary composition to make applicative style more convenient. 34 | 35 | (.::) :: (d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e 36 | f .:: g = \x y z -> f (g x y z) 37 | 38 | 39 | 40 | 41 | 42 | -- | A @Continuer@ is a higher-order representation of the body of a shift, 43 | -- which contains continue points. A term such as @foo x * continue x@ would 44 | -- correspond to a function @\c -> foo x * c x@. We can therefore represent 45 | -- this by using a reader. 46 | 47 | type Continuer a = Reader (Scope TermF) a 48 | 49 | 50 | -- | This is the core of what makes a continuer go. Every constructor is 51 | -- propagated algebraically except @Continue@ which is swapped for @continue@, 52 | -- constructing the basic @Continuer@. 53 | 54 | continue :: Term -> Continuer Term 55 | continue x = do sc <- ask 56 | return (instantiate sc [x]) 57 | 58 | 59 | 60 | 61 | 62 | -- | We transform a term into a @Continuer@ by just replacing every maximal 63 | -- term @Continue x@ with @continue x@, leaving everything else alone. 64 | 65 | makeContinuer :: Term -> Continuer Term 66 | makeContinuer (Var v) = pure (Var v) 67 | makeContinuer (In (Continue m)) = continue (instantiate0 m) 68 | makeContinuer (In x) = In <$> traverse (underF makeContinuer) x 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | -- | Another important type is @Shifter@. This is a tyoe that makes it easy 77 | -- to replace the @Shift@ terms with their appropriate reset value. However, 78 | -- since there are multiple shifts inside any given reset, we track which 79 | -- shifted term we're at when we replace it, hence the use of @State@. 80 | -- Additionally, because the replacement terms are not yet known, we instead 81 | -- need to compose up a function that will pick the appropriate one from a 82 | -- list. 83 | 84 | newtype Shifter a = Shifter { runShifter :: State Int (a, [(String,Term)]) } 85 | 86 | 87 | -- | A shifter is evaluated by evaluating it's state starting with 0. 88 | 89 | evalShifter :: Shifter a -> (a, [(String,Term)]) 90 | evalShifter (Shifter x) = evalState x 0 91 | 92 | 93 | instance Functor Shifter where 94 | fmap f x = Shifter $ do 95 | (x',nes) <- runShifter x 96 | return (f x', nes) 97 | 98 | 99 | instance Applicative Shifter where 100 | pure x = Shifter (pure (x, [])) 101 | f <*> x = Shifter $ do 102 | (f',nes) <- runShifter f 103 | (x',nes') <- runShifter x 104 | return (f' x', nes ++ nes') 105 | 106 | 107 | 108 | 109 | -- | The @shift@ function is the core of shifting behavior, much like 110 | -- @continue@ is the core of continuing behavior. @shift@ will put its term 111 | -- into the list of shifted terms to return, and the functiont to look up its 112 | -- replacement does so by projecting out the current index according to the 113 | -- state, which is itself incremented. 114 | 115 | shift :: Term -> Shifter Term 116 | shift x = Shifter $ do 117 | i <- get 118 | put (i+1) 119 | let n = "auto_shift_" ++ show i 120 | return (Var (Free (FreeVar n)), [(n,x)]) 121 | 122 | 123 | 124 | 125 | 126 | -- | We transform a term into a @Shifter@ by just replacing every maximal 127 | -- term @Shift res x@ with @shift x@, leaving everything else alone. 128 | 129 | makeShifter :: Term -> Shifter Term 130 | makeShifter (Var v) = pure (Var v) 131 | makeShifter (In (Shift _ m)) = shift (instantiate0 m) 132 | makeShifter (In x) = In <$> traverse (underF makeShifter) x 133 | 134 | 135 | 136 | 137 | 138 | -- | We can reset a number of shifts by collecting up the maximal shifts in 139 | -- an expression, converting their bodies to the appropriate continuers, 140 | -- then sequencing the corresponding continuized values, and then running that 141 | -- sequenced continuized value on the continuation. We repeat this until there 142 | -- are no shifts to reset, at which point we're done'. 143 | 144 | reset :: Term -> Term 145 | reset x 146 | | null shifts = m 147 | | otherwise = reset (foldr abstractor m shifts) 148 | where 149 | (m,shifts) = evalShifter (makeShifter x) 150 | abstractor (n,x') m' = runReader (makeContinuer x') (scope [n] m') 151 | 152 | 153 | 154 | 155 | 156 | -- | A term is decontinuized by resetting every reset term in a bottom up way. 157 | 158 | decontinuize :: Term -> Term 159 | decontinuize (Var v) = Var v 160 | decontinuize (In (Reset _ m)) = reset (decontinuize (instantiate0 m)) 161 | decontinuize (In x) = In (fmap (under decontinuize) x) -------------------------------------------------------------------------------- /src/Continuations/Demo.sfp: -------------------------------------------------------------------------------- 1 | module Demo where 2 | 3 | data Nat where 4 | | Zero : Nat 5 | | Suc (n : Nat) : Nat 6 | end 7 | 8 | let plus : Nat -> Nat -> Nat where 9 | | plus Zero n = n 10 | | plus (Suc m) n = Suc (plus m n) 11 | end 12 | 13 | reset natR from Nat to Nat end 14 | 15 | let ex0 : Quoted Nat 16 | = `(reset natR 17 | in Suc (Suc (shift natR 18 | in plus (continue Zero) 19 | (continue (Suc Zero))))) 20 | end 21 | 22 | let ex1 : Quoted[natR] Nat 23 | = `(Suc (Suc (shift natR 24 | in plus (continue Zero) 25 | (continue (Suc Zero))))) 26 | end 27 | 28 | -- this will fail because it uses continuations outside of quotes 29 | {- 30 | let ex2 : Nat 31 | = reset natR 32 | in Suc (Suc (shift natR 33 | in plus (continue Zero) 34 | (continue (Suc Zero)))) 35 | end 36 | --} 37 | 38 | -- this will fail because it uses a reset point that's not in scope 39 | {- 40 | let ex3 : Quoted Nat 41 | = `(Suc (Suc (shift natR 42 | in plus (continue Zero) 43 | (continue (Suc Zero))))) 44 | end 45 | --} 46 | 47 | -- this will fail because it continues without having a shifted reset point 48 | {- 49 | let ex5 : Quoted Nat 50 | = `(reset natR 51 | in Suc (Suc (plus (continue Zero) 52 | (continue (Suc Zero))))) 53 | end 54 | --} 55 | 56 | end -------------------------------------------------------------------------------- /src/Continuations/Unification/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | -- This module defines the core types of a monadic elaborator. 13 | 14 | module Continuations.Unification.Elaborator where 15 | 16 | import Utils.Env 17 | import Utils.Plicity 18 | import Utils.Unifier 19 | import Utils.Vars 20 | import Continuations.Core.ConSig 21 | import Continuations.Core.Term 22 | 23 | import qualified Control.Lens as L 24 | import Control.Monad.State 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | -- The quote level judgment tracks how deeply nested under quotes a term is. 33 | 34 | data QLJ a = QLJ a Int 35 | deriving (Functor) 36 | 37 | 38 | 39 | 40 | 41 | -- | A signature is a collection of constructors together with their 42 | -- constructor signatures. This is used during type checking and elaboration 43 | -- to define the underlying type theory. 44 | 45 | type Signature = [((String,String),ConSig)] 46 | 47 | 48 | 49 | 50 | 51 | -- | A definition consists of a declared name together with its definition 52 | -- and its type. 53 | 54 | type Definitions = [((String,String),(Term,Term))] 55 | 56 | definitionsToEnvironment :: Definitions -> Env (String,String) Term 57 | definitionsToEnvironment defs = 58 | [ (x,m) | (x,(m,_)) <- defs ] 59 | 60 | 61 | 62 | 63 | 64 | -- | A context contains generated variables together with their display names, 65 | -- and their declared types. 66 | 67 | type Context = [(FreeVar,QLJ Term)] 68 | 69 | 70 | 71 | 72 | 73 | -- | Aliases are just maps from local names to absolute names. 74 | 75 | type Aliases = [(Either String (String,String), (String,String))] 76 | 77 | 78 | 79 | 80 | 81 | -- | Open functions have to story their pattern matching definitions so they 82 | -- can be re-built when new instances are added. 83 | 84 | type OpenFunction = ((String,String),(Term,[Plicity],CaseMotive,[Clause])) 85 | 86 | 87 | 88 | 89 | 90 | -- | Declared reset points are just a collection of reset point names with 91 | -- their declared types. 92 | 93 | type ResetPoints = [(String,(Term,Term))] 94 | 95 | 96 | 97 | 98 | 99 | -- | The definition of the state to be carried by the type checking monad for 100 | -- this particular variant. 101 | 102 | data ElabState 103 | = ElabState 104 | { _signature :: Signature 105 | , _definitions :: Definitions 106 | , _context :: Context 107 | , _substitution :: Substitution TermF 108 | , _nextMeta :: MetaVar 109 | , _aliases :: Aliases 110 | , _moduleName :: String 111 | , _moduleNames :: [String] 112 | , _openData :: [(String,String)] 113 | , _openFunctions :: [OpenFunction] 114 | , _quoteLevel :: Int 115 | , _resetPoints :: ResetPoints 116 | , _resetPointsInScope :: [String] 117 | , _shiftsInScope :: [String] 118 | } 119 | L.makeLenses ''ElabState 120 | 121 | 122 | type Elaborator = StateT ElabState (Either String) 123 | 124 | 125 | type TypeChecker = Elaborator 126 | 127 | 128 | runElaborator :: Elaborator a 129 | -> Signature 130 | -> Definitions 131 | -> Context 132 | -> Aliases 133 | -> String 134 | -> [String] 135 | -> [(String,String)] 136 | -> [OpenFunction] 137 | -> Either String (a,ElabState) 138 | runElaborator e sig defs ctx als modname mods odata ofuns = 139 | runStateT 140 | e 141 | (ElabState sig defs ctx [] (MetaVar 0) als modname mods odata ofuns 0 [] [] []) 142 | 143 | 144 | runElaborator0 :: Elaborator a -> Either String (a,ElabState) 145 | runElaborator0 e = runElaborator e [] [] [] [] "" [] [] [] 146 | 147 | 148 | when' :: Elaborator a -> Elaborator () -> Elaborator () 149 | when' e1 e2 = do s <- get 150 | case runStateT e1 s of 151 | Left _ -> return () 152 | Right _ -> e2 -------------------------------------------------------------------------------- /src/Continuations/Unification/REPL.hs: -------------------------------------------------------------------------------- 1 | module Continuations.Unification.REPL where 2 | 3 | import Control.Monad.Reader (runReaderT) 4 | import System.IO 5 | import Utils.ABT 6 | import Utils.Env 7 | import Utils.Eval 8 | import Utils.Names 9 | import Utils.Pretty 10 | import Continuations.Core.ConSig 11 | import Continuations.Core.Evaluation 12 | import Continuations.Core.Parser 13 | import Continuations.Core.Term 14 | import Continuations.Unification.Elaborator 15 | import Continuations.Unification.Elaboration 16 | import Continuations.Unification.TypeChecking 17 | 18 | 19 | 20 | flushStr :: String -> IO () 21 | flushStr str = putStr str >> hFlush stdout 22 | 23 | readPrompt :: String -> IO String 24 | readPrompt prompt = flushStr prompt >> getLine 25 | 26 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 27 | until_ p prompt action = do 28 | result <- prompt 29 | if p result 30 | then return () 31 | else action result >> until_ p prompt action 32 | 33 | repl :: String -> IO () 34 | repl src = case loadProgram src of 35 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 36 | Right (sig,defs,ctx,env) 37 | -> do hSetBuffering stdin LineBuffering 38 | until_ (== ":quit") 39 | (readPrompt "$> ") 40 | (evalAndPrint sig defs ctx env) 41 | where 42 | loadProgram :: String 43 | -> Either String ( Signature 44 | , Definitions 45 | , Context 46 | , Env (String,String) Term 47 | ) 48 | loadProgram src 49 | = do prog <- parseProgram src 50 | (_,ElabState sig defs ctx _ _ _ _ _ _ _ _ _ _ _) <- 51 | runElaborator0 (elabProgram prog) 52 | let env = definitionsToEnvironment defs 53 | return (sig,defs,ctx,env) 54 | 55 | loadTerm :: Signature 56 | -> Definitions 57 | -> Context 58 | -> Env (String,String) Term 59 | -> String 60 | -> Either String Term 61 | loadTerm sig defs ctx env src 62 | = do tm0 <- parseTerm src 63 | let tm = freeToDefined (In . Defined . BareLocal) tm0 64 | als = [ (Right p,p) | (p,_) <- sig ] 65 | ++ [ (Right p,p) | (p,_) <- defs ] 66 | case runElaborator (infer tm) sig defs ctx als "" [] [] [] of 67 | Left e -> Left e 68 | Right ((etm,_),_) -> runReaderT (paramEval 0 etm) env 69 | 70 | evalAndPrint :: Signature 71 | -> Definitions 72 | -> Context 73 | -> Env (String,String) Term 74 | -> String 75 | -> IO () 76 | evalAndPrint _ _ _ _ "" = return () 77 | evalAndPrint sig defs ctx env src 78 | = case loadTerm sig defs ctx env src of 79 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 80 | Right v -> flushStr (pretty v ++ "\n") 81 | 82 | replFile :: String -> IO () 83 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Dependent/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | module Dependent.Core.ConSig where 10 | 11 | import Utils.ABT 12 | import Utils.Pretty (pretty) 13 | import Utils.Telescope 14 | import Dependent.Core.DeclArg 15 | import Dependent.Core.Term 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | newtype ConSig = ConSig (BindingTelescope (Scope TermF)) 24 | 25 | 26 | instance Show ConSig where 27 | show (ConSig (BindingTelescope ascs bsc)) = 28 | binders ++ " " ++ pretty (body bsc) 29 | where 30 | binders = 31 | unwords 32 | (zipWith 33 | (\n a -> "(" ++ n ++ " : " ++ a ++ ")") 34 | ns 35 | as) 36 | as = map (pretty.body) ascs 37 | ns = names bsc 38 | 39 | 40 | conSigH :: [DeclArg] -> Term -> ConSig 41 | conSigH declas b = ConSig (bindingTelescopeH xs as b) 42 | where (xs,as) = unzip [ (x,a) | DeclArg x a <- declas ] 43 | 44 | 45 | freeToDefinedConSig :: ConSig -> ConSig 46 | freeToDefinedConSig (ConSig tele) = 47 | ConSig (fmap (freeToDefinedScope (In . Defined)) tele) -------------------------------------------------------------------------------- /src/Dependent/Core/DeclArg.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | module Dependent.Core.DeclArg where 6 | 7 | import Utils.Pretty 8 | import Dependent.Core.Term 9 | 10 | 11 | 12 | data DeclArg = DeclArg String Term 13 | 14 | instance Show DeclArg where 15 | show (DeclArg x t) = "(" ++ x ++ " : " ++ pretty t ++ ")" -------------------------------------------------------------------------------- /src/Dependent/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | -- | This module defines how to evaluate terms in the dependently typed lambda 14 | -- calculus. 15 | 16 | module Dependent.Core.Evaluation where 17 | 18 | import Control.Monad.Except 19 | 20 | import Utils.ABT 21 | import Utils.Env 22 | import Utils.Eval 23 | import Utils.Pretty 24 | import Utils.Telescope 25 | import Dependent.Core.Term 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | -- | Because a case expression can be evaluated under a binder, it's necessary 34 | -- to determine when a match failure is real or illusory. For example, if we 35 | -- have the function @\x -> case x of { Zero -> True ; _ -> False }@, and 36 | -- naively tried to match, the first clause would fail, because @x =/= Zero@, 37 | -- and the second would succeed, reducing this function to @\x -> False@. 38 | -- But this would be bad, because if we then applied this function to @Zero@, 39 | -- the result is just @False@. But if we had applied the original function to 40 | -- @Zero@ and evaluated, it would reduce to @True@. Instead, we need to know 41 | -- more than just did the match succeed or fail, but rather, did it succeed, 42 | -- definitely fail because of a constructor mismatch, or is it uncertain 43 | -- because of insufficient information (e.g. a variable or some other 44 | -- non-constructor expression). We can use this type to represent that 45 | -- three-way distinction between definite matches, definite failures, and 46 | -- unknown situations. 47 | 48 | data MatchResult a 49 | = Success a 50 | | Unknown 51 | | Failure 52 | deriving (Functor) 53 | 54 | 55 | instance Applicative MatchResult where 56 | pure = Success 57 | 58 | Success f <*> Success x = Success (f x) 59 | Unknown <*> _ = Unknown 60 | _ <*> Unknown = Unknown 61 | _ <*> _ = Failure 62 | 63 | 64 | instance Monad MatchResult where 65 | return = Success 66 | 67 | Success x >>= f = f x 68 | Unknown >>= _ = Unknown 69 | Failure >>= _ = Failure 70 | 71 | 72 | -- | Pattern matching for case expressions. 73 | 74 | matchPattern :: Pattern -> Term -> MatchResult [Term] 75 | matchPattern (Var _) v = Success [v] 76 | matchPattern (In (ConPat c ps)) (In (Con c' as)) 77 | | c == c' && length ps == length as = 78 | fmap concat (zipWithM matchPattern (map body ps) (map body as)) 79 | | otherwise = Failure 80 | matchPattern (In (AssertionPat _)) v = Success [v] 81 | matchPattern _ _ = Unknown 82 | 83 | matchPatterns :: [Pattern] -> [Term] -> MatchResult [Term] 84 | matchPatterns [] [] = 85 | Success [] 86 | matchPatterns (p:ps) (m:ms) = 87 | do vs <- matchPattern p m 88 | vs' <- matchPatterns ps ms 89 | return $ vs ++ vs' 90 | matchPatterns _ _ = Failure 91 | 92 | matchClauses :: [Clause] -> [Term] -> MatchResult Term 93 | matchClauses [] _ = Failure 94 | matchClauses (Clause pscs sc:cs) ms = 95 | case matchPatterns (map patternBody pscs) ms of 96 | Failure -> matchClauses cs ms 97 | Unknown -> Unknown 98 | Success vs -> Success (instantiate sc vs) 99 | 100 | 101 | 102 | 103 | 104 | -- | Standard eager evaluation. 105 | 106 | instance Eval (Env String Term) Term where 107 | eval (Var v) = 108 | return $ Var v 109 | eval (In (Defined x)) = 110 | do env <- environment 111 | case lookup x env of 112 | Nothing -> throwError $ "Unknown constant/defined term: " ++ x 113 | Just m -> return m 114 | eval (In (Ann m _)) = 115 | eval (instantiate0 m) 116 | eval (In Type) = 117 | return $ In Type 118 | eval (In (Fun a sc)) = 119 | do ea <- underF eval a 120 | esc <- underF eval sc 121 | return $ In (Fun ea esc) 122 | eval (In (Lam sc)) = 123 | do esc <- underF eval sc 124 | return $ In (Lam esc) 125 | eval (In (App f a)) = 126 | do ef <- eval (instantiate0 f) 127 | ea <- eval (instantiate0 a) 128 | case ef of 129 | In (Lam sc) -> eval (instantiate sc [ea]) 130 | _ -> return $ appH ef ea 131 | eval (In (Con c as)) = 132 | do eas <- mapM (eval.instantiate0) as 133 | return $ conH c eas 134 | eval (In (Case ms mot cs)) = 135 | do ems <- mapM eval (map instantiate0 ms) 136 | case matchClauses cs ems of 137 | Success b -> eval b 138 | Unknown -> 139 | do emot <- eval mot 140 | return $ caseH ems emot cs 141 | Failure -> 142 | throwError $ "Incomplete pattern match: " 143 | ++ pretty (In (Case ms mot cs)) 144 | 145 | 146 | instance Eval (Env String Term) CaseMotive where 147 | eval (CaseMotive (BindingTelescope ascs bsc)) = 148 | do eascs <- mapM (underF eval) ascs 149 | ebsc <- underF eval bsc 150 | return $ CaseMotive (BindingTelescope eascs ebsc) 151 | 152 | 153 | instance Eval (Env String Term) Clause where 154 | eval (Clause pscs bsc) = 155 | do epscs <- mapM eval pscs 156 | ebsc <- underF eval bsc 157 | return $ Clause epscs ebsc 158 | 159 | 160 | instance Eval (Env String Term) (PatternF (Scope TermF)) where 161 | eval (PatternF x) = 162 | do ex <- underF eval x 163 | return $ PatternF ex 164 | 165 | 166 | instance Eval (Env String Term) (ABT (PatternFF (Scope TermF))) where 167 | eval (Var v) = 168 | return $ Var v 169 | eval (In (ConPat c ps)) = 170 | do eps <- mapM (underF eval) ps 171 | return $ In (ConPat c eps) 172 | eval (In (AssertionPat m)) = 173 | do em <- underF eval m 174 | return $ In (AssertionPat em) -------------------------------------------------------------------------------- /src/Dependent/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module defines what it means to be a program in the dependently 10 | -- typed lambda calculus. 11 | 12 | module Dependent.Core.Program where 13 | 14 | import Utils.Pretty 15 | import Dependent.Core.ConSig 16 | import Dependent.Core.DeclArg 17 | import Dependent.Core.Term 18 | 19 | import Data.List (intercalate) 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | -- | A program is just a series of 'Statement's. 28 | 29 | newtype Program = Program [Statement] 30 | 31 | instance Show Program where 32 | show (Program stmts) = intercalate "\n\n" (map show stmts) 33 | 34 | 35 | 36 | 37 | 38 | -- | A 'Statement' is either a 'TypeDeclaration' or a 'TermDeclaration'. 39 | 40 | data Statement 41 | = TyDecl TypeDeclaration 42 | | TmDecl TermDeclaration 43 | 44 | instance Show Statement where 45 | show (TyDecl td) = show td 46 | show (TmDecl td) = show td 47 | 48 | 49 | 50 | 51 | 52 | -- | A term can be declared either with a simple equality, as in 53 | -- 54 | -- > let not : Bool -> Bool 55 | -- > = \b -> case b of 56 | -- > | True -> False 57 | -- > | False -> True 58 | -- > end 59 | -- > end 60 | -- 61 | -- or with a pattern match, as in 62 | -- 63 | -- > let not : Bool -> Bool where 64 | -- > | not True = False 65 | -- > | not False = True 66 | -- > end 67 | 68 | data TermDeclaration 69 | = TermDeclaration String Term Term 70 | | WhereDeclaration String Term [([String],[Pattern],Term)] 71 | 72 | instance Show TermDeclaration where 73 | show (TermDeclaration n ty def) = 74 | "let " ++ n ++ " : " ++ pretty ty ++ " = " ++ pretty def ++ " end" 75 | show (WhereDeclaration n ty preclauses) = 76 | "let " ++ n ++ " : " ++ pretty ty ++ " where " 77 | ++ intercalate " | " (map showPreclause preclauses) 78 | where 79 | showPreclause :: ([String],[Pattern],Term) -> String 80 | showPreclause (_,ps,b) = 81 | intercalate " || " (map (parenthesize Nothing) ps) 82 | ++ " -> " ++ pretty b 83 | 84 | 85 | 86 | 87 | 88 | -- | A type is declared with a GADT-like notation, however instead of giving 89 | -- the type of a constructor, as in Haskell or Agda, a constructor's signature 90 | -- is given via exemplified application, as in: 91 | -- 92 | -- @ 93 | -- data List (a : Type) where 94 | -- | Nil : List a 95 | -- | Cons (x : a) (xs : List a) : List a 96 | -- end 97 | -- @ 98 | -- 99 | -- Types with no constructors need no @where@: 100 | -- 101 | -- > data Void end 102 | 103 | data TypeDeclaration 104 | = TypeDeclaration String [DeclArg] [(String,ConSig)] 105 | 106 | instance Show TypeDeclaration where 107 | show (TypeDeclaration tycon tyargs []) = 108 | "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 109 | show (TypeDeclaration tycon tyargs alts) = 110 | "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " where" 111 | ++ concat [ "\n" ++ c ++ " : " ++ show sig | (c,sig) <- alts ] 112 | ++ "\nend" -------------------------------------------------------------------------------- /src/Dependent/Demo.sfp: -------------------------------------------------------------------------------- 1 | data Unit where 2 | | U : Unit 3 | end 4 | 5 | data Inv (a : Type) (b : Type) (f : (x : a) -> b) (y : b) where 6 | | InvEl (a : Type) (b : Type) (f : (x : a) -> b) (x : a) : Inv a b f (f x) 7 | end 8 | 9 | data Bool where 10 | | True : Bool 11 | | False : Bool 12 | end 13 | 14 | let not : (b : Bool) -> Bool 15 | = \b -> case b 16 | motive (b' : Bool) || Bool 17 | of 18 | | True -> False 19 | | False -> True 20 | end 21 | end 22 | 23 | let ex : Inv Bool Bool not True 24 | = InvEl Bool Bool not False 25 | end 26 | 27 | data Nat where 28 | | Zero : Nat 29 | | Suc (n : Nat) : Nat 30 | end 31 | 32 | let plusOne : (n : Nat) -> Nat 33 | = \n -> Suc n 34 | end 35 | 36 | let ex2 : Inv Nat Nat (\n -> Suc n) (Suc Zero) 37 | = InvEl Nat Nat plusOne Zero 38 | end 39 | 40 | data Vec (a : Type) (n : Nat) where 41 | | Nil (a : Type) : Vec a Zero 42 | | Cons (a : Type) (n : Nat) (x : a) (xs : Vec a n) : Vec a (Suc n) 43 | end 44 | 45 | let vapp : (a : Type) -> (b : Type) -> (n : Nat) -> (fs : Vec ((x : a) -> b) n) -> (xs : Vec a n) -> Vec b n 46 | = \a -> \b -> \n -> \fs -> \xs -> 47 | case n || fs || xs 48 | motive (n' : Nat) || (fs' : Vec ((x : a) -> b) n') || (xs' : Vec a n') || Vec b n' 49 | of 50 | | Zero || Nil .((x : a) -> b) || Nil .a -> Nil b 51 | | Suc n' || Cons .((x : a) -> b) .n' f fs' || Cons .a .n' x xs' -> Cons b n' (f x) (vapp a b n' fs' xs') 52 | end 53 | end 54 | 55 | let plus : Nat -> Nat -> Nat where 56 | | plus Zero n = n 57 | | plus (Suc m) n = Suc (plus m n) 58 | end 59 | 60 | let append : (a : Type) -> (m : Nat) -> (n : Nat) 61 | -> (xs : Vec a m) -> (ys : Vec a n) -> Vec a (plus m n) 62 | = \a -> \m -> \n -> \xs -> \ys -> 63 | case m || xs 64 | motive (m' : Nat) || (xs' : Vec a m') || Vec a (plus m' n) 65 | of 66 | | Zero || Nil .a -> ys 67 | | Suc m' || Cons .a .m' x xs' -> Cons a (plus m' n) x (append a m' n xs' ys) 68 | end 69 | end 70 | -------------------------------------------------------------------------------- /src/Dependent/Monadic/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -- This module defines the core types of a monadic elaborator. 12 | 13 | module Dependent.Monadic.Elaborator where 14 | 15 | import Utils.Env 16 | import Utils.Vars 17 | import Dependent.Core.ConSig 18 | import Dependent.Core.Term 19 | 20 | import qualified Control.Lens as L 21 | import Control.Monad.State 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | -- | A signature is a collection of constructors together with their 30 | -- constructor signatures. This is used during type checking and elaboration 31 | -- to define the underlying type theory. 32 | 33 | type Signature = [(String,ConSig)] 34 | 35 | 36 | 37 | 38 | 39 | -- | A definition consists of a declared name together with its definition 40 | -- and its type. 41 | 42 | type Definitions = [(String,(Term,Term))] 43 | 44 | definitionsToEnvironment :: Definitions -> Env String Term 45 | definitionsToEnvironment defs = 46 | [ (x,m) | (x,(m,_)) <- defs ] 47 | 48 | 49 | 50 | 51 | 52 | -- | A context contains generated variables together with their display names, 53 | -- and their declared types. 54 | 55 | type Context = [(FreeVar,Term)] 56 | 57 | 58 | 59 | 60 | 61 | -- | The definition of the state to be carried by the type checking monad for 62 | -- this particular variant. We need only the bare minimum of a signature, 63 | -- some defined terms, and a typing context. 64 | 65 | data ElabState 66 | = ElabState 67 | { _signature :: Signature 68 | , _definitions :: Definitions 69 | , _context :: Context 70 | } 71 | L.makeLenses ''ElabState 72 | 73 | 74 | type Elaborator a = StateT ElabState (Either String) a 75 | 76 | 77 | type TypeChecker a = Elaborator a 78 | 79 | 80 | runElaborator :: Elaborator a 81 | -> Signature 82 | -> Definitions 83 | -> Context 84 | -> Either String (a,ElabState) 85 | runElaborator e sig defs ctx = 86 | runStateT e (ElabState sig defs ctx) 87 | 88 | 89 | runElaborator0 :: Elaborator a -> Either String (a,ElabState) 90 | runElaborator0 e = runElaborator e [] [] [] 91 | 92 | 93 | when' :: Elaborator a -> Elaborator () -> Elaborator () 94 | when' e1 e2 = do s <- get 95 | case runStateT e1 s of 96 | Left _ -> return () 97 | Right _ -> e2 -------------------------------------------------------------------------------- /src/Dependent/Monadic/Equality.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module defines equality on dependently typed LC terms. Since this 10 | -- variant doesn't use unification, all that's necessary is simple equality. 11 | 12 | module Dependent.Monadic.Equality where 13 | 14 | import Dependent.Core.Term 15 | 16 | import Data.Functor.Classes 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | instance Eq1 TermF where 25 | eq1 (Defined n) (Defined n') = 26 | n == n' 27 | eq1 (Ann m t) (Ann m' t') = 28 | m == m' && t == t' 29 | eq1 Type Type = True 30 | eq1 (Fun arg sc) (Fun arg' sc') = 31 | arg == arg' && sc == sc' 32 | eq1 (Lam sc) (Lam sc') = 33 | sc == sc' 34 | eq1 (App f x) (App f' x') = 35 | f == f' && x == x' 36 | eq1 (Con c as) (Con c' as') = 37 | c == c' && as == as' 38 | eq1 (Case as mot cls) (Case as' mot' cls') = 39 | as == as' && eq1 mot mot' && 40 | length cls == length cls' && and (zipWith eq1 cls cls') 41 | eq1 _ _ = False 42 | 43 | 44 | instance Eq1 CaseMotiveF where 45 | eq1 (CaseMotive t) (CaseMotive t') = eq1 t t' 46 | 47 | 48 | instance Eq1 ClauseF where 49 | eq1 (Clause pscs bsc) (Clause pscs' bsc') = 50 | length pscs == length pscs' && and (zipWith eq1 pscs pscs') && 51 | bsc == bsc' 52 | 53 | 54 | instance Eq1 PatternF where 55 | eq1 (PatternF x) (PatternF y) = x == y 56 | 57 | 58 | instance Eq a => Eq1 (PatternFF a) where 59 | eq1 (ConPat c ps) (ConPat c' ps') = 60 | c == c' && ps == ps' 61 | eq1 (AssertionPat m) (AssertionPat m') = 62 | m == m' 63 | eq1 _ _ = False -------------------------------------------------------------------------------- /src/Dependent/Monadic/REPL.hs: -------------------------------------------------------------------------------- 1 | module Dependent.Monadic.REPL where 2 | 3 | import Control.Monad.Reader (runReaderT) 4 | import System.IO 5 | 6 | import Utils.ABT 7 | import Utils.Env 8 | import Utils.Eval 9 | import Utils.Pretty 10 | import Dependent.Core.ConSig 11 | import Dependent.Core.Evaluation 12 | import Dependent.Core.Parser 13 | import Dependent.Core.Term 14 | import Dependent.Monadic.Elaborator 15 | import Dependent.Monadic.Elaboration 16 | import Dependent.Monadic.TypeChecking 17 | 18 | 19 | 20 | flushStr :: String -> IO () 21 | flushStr str = putStr str >> hFlush stdout 22 | 23 | readPrompt :: String -> IO String 24 | readPrompt prompt = flushStr prompt >> getLine 25 | 26 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 27 | until_ p prompt action = do 28 | result <- prompt 29 | if p result 30 | then return () 31 | else action result >> until_ p prompt action 32 | 33 | repl :: String -> IO () 34 | repl src = case loadProgram src of 35 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 36 | Right (sig,defs,ctx,env) 37 | -> do hSetBuffering stdin LineBuffering 38 | until_ (== ":quit") 39 | (readPrompt "$> ") 40 | (evalAndPrint sig defs ctx env) 41 | where 42 | loadProgram :: String -> Either String (Signature,Definitions,Context,Env String Term) 43 | loadProgram src 44 | = do prog <- parseProgram src 45 | (_,ElabState sig defs ctx) <- runElaborator0 (elabProgram prog) 46 | let env = definitionsToEnvironment defs 47 | return (sig,defs,ctx,env) 48 | 49 | loadTerm :: Signature -> Definitions -> Context -> Env String Term -> String -> Either String Term 50 | loadTerm sig defs ctx env src 51 | = do tm0 <- parseTerm src 52 | let tm = freeToDefined (In . Defined) tm0 53 | case runElaborator (infer tm) sig defs ctx of 54 | Left e -> Left e 55 | Right _ -> runReaderT (eval tm) env 56 | 57 | evalAndPrint :: Signature -> Definitions -> Context -> Env String Term -> String -> IO () 58 | evalAndPrint _ _ _ _ "" = return () 59 | evalAndPrint sig defs ctx env src 60 | = case loadTerm sig defs ctx env src of 61 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 62 | Right v -> flushStr (pretty v ++ "\n") 63 | 64 | replFile :: String -> IO () 65 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Dependent/Unification/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -- This module defines the core types of a monadic elaborator. 12 | 13 | module Dependent.Unification.Elaborator where 14 | 15 | import Utils.Env 16 | import Utils.Unifier 17 | import Utils.Vars 18 | import Dependent.Core.ConSig 19 | import Dependent.Core.Term 20 | 21 | import qualified Control.Lens as L 22 | import Control.Monad.State 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | -- | A signature is a collection of constructors together with their 31 | -- constructor signatures. This is used during type checking and elaboration 32 | -- to define the underlying type theory. 33 | 34 | type Signature = [(String,ConSig)] 35 | 36 | 37 | 38 | 39 | 40 | -- | A definition consists of a declared name together with its definition 41 | -- and its type. 42 | 43 | type Definitions = [(String,(Term,Term))] 44 | 45 | definitionsToEnvironment :: Definitions -> Env String Term 46 | definitionsToEnvironment defs = 47 | [ (x,m) | (x,(m,_)) <- defs ] 48 | 49 | 50 | 51 | 52 | 53 | -- | A context contains generated variables together with their display names, 54 | -- and their declared types. 55 | 56 | type Context = [(FreeVar,Term)] 57 | 58 | 59 | 60 | 61 | 62 | -- | The definition of the state to be carried by the type checking monad for 63 | -- this particular variant. We need only the bare minimum of a signature, 64 | -- some defined terms, and a typing context. 65 | 66 | data ElabState 67 | = ElabState 68 | { _signature :: Signature 69 | , _definitions :: Definitions 70 | , _context :: Context 71 | , _substitution :: Substitution TermF 72 | , _nextMeta :: MetaVar 73 | } 74 | L.makeLenses ''ElabState 75 | 76 | 77 | type Elaborator = StateT ElabState (Either String) 78 | 79 | 80 | type TypeChecker = Elaborator 81 | 82 | 83 | runElaborator :: Elaborator a 84 | -> Signature 85 | -> Definitions 86 | -> Context 87 | -> Either String (a,ElabState) 88 | runElaborator e sig defs ctx = 89 | runStateT e (ElabState sig defs ctx [] (MetaVar 0)) 90 | 91 | 92 | runElaborator0 :: Elaborator a -> Either String (a,ElabState) 93 | runElaborator0 e = runElaborator e [] [] [] 94 | 95 | 96 | when' :: Elaborator a -> Elaborator () -> Elaborator () 97 | when' e1 e2 = do s <- get 98 | case runStateT e1 s of 99 | Left _ -> return () 100 | Right _ -> e2 -------------------------------------------------------------------------------- /src/Dependent/Unification/REPL.hs: -------------------------------------------------------------------------------- 1 | module Dependent.Unification.REPL where 2 | 3 | import Control.Monad.Reader (runReaderT) 4 | import System.IO 5 | 6 | import Utils.ABT 7 | import Utils.Env 8 | import Utils.Eval 9 | import Utils.Pretty 10 | import Dependent.Core.ConSig 11 | import Dependent.Core.Evaluation 12 | import Dependent.Core.Parser 13 | import Dependent.Core.Term 14 | import Dependent.Unification.Elaborator 15 | import Dependent.Unification.Elaboration 16 | import Dependent.Unification.TypeChecking 17 | 18 | 19 | 20 | flushStr :: String -> IO () 21 | flushStr str = putStr str >> hFlush stdout 22 | 23 | readPrompt :: String -> IO String 24 | readPrompt prompt = flushStr prompt >> getLine 25 | 26 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 27 | until_ p prompt action = do 28 | result <- prompt 29 | if p result 30 | then return () 31 | else action result >> until_ p prompt action 32 | 33 | repl :: String -> IO () 34 | repl src = case loadProgram src of 35 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 36 | Right (sig,defs,ctx,env) 37 | -> do hSetBuffering stdin LineBuffering 38 | until_ (== ":quit") 39 | (readPrompt "$> ") 40 | (evalAndPrint sig defs ctx env) 41 | where 42 | loadProgram :: String -> Either String (Signature,Definitions,Context,Env String Term) 43 | loadProgram src 44 | = do prog <- parseProgram src 45 | (_,ElabState sig defs ctx _ _) <- runElaborator0 (elabProgram prog) 46 | let env = definitionsToEnvironment defs 47 | return (sig,defs,ctx,env) 48 | 49 | loadTerm :: Signature -> Definitions -> Context -> Env String Term -> String -> Either String Term 50 | loadTerm sig defs ctx env src 51 | = do tm0 <- parseTerm src 52 | let tm = freeToDefined (In . Defined) tm0 53 | case runElaborator (infer tm) sig defs ctx of 54 | Left e -> Left e 55 | Right _ -> runReaderT (eval tm) env 56 | 57 | evalAndPrint :: Signature -> Definitions -> Context -> Env String Term -> String -> IO () 58 | evalAndPrint _ _ _ _ "" = return () 59 | evalAndPrint sig defs ctx env src 60 | = case loadTerm sig defs ctx env src of 61 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 62 | Right v -> flushStr (pretty v ++ "\n") 63 | 64 | replFile :: String -> IO () 65 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Dependent/Unification/Unification.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -- | This module defines unification of dependent types. 15 | 16 | module Dependent.Unification.Unification where 17 | 18 | import Utils.ABT 19 | import Utils.Elaborator 20 | import Utils.Pretty 21 | import Utils.Telescope 22 | import Utils.Unifier 23 | import Dependent.Core.Term 24 | import Dependent.Unification.Elaborator 25 | 26 | import Control.Monad.Except 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | -- | Equating terms by trivial structural equations. 35 | 36 | instance MonadUnify TermF Elaborator where 37 | equate (Defined n1) (Defined n2) = 38 | if n1 == n2 39 | then return [] 40 | else throwError $ "Mismatching names " ++ n1 ++ " and " ++ n2 41 | equate (Ann m1 t1) (Ann m2 t2) = 42 | return [ Equation (instantiate0 m1) (instantiate0 m2) 43 | , Equation (instantiate0 t1) (instantiate0 t2) 44 | ] 45 | equate Type Type = 46 | return [] 47 | equate (Fun a1 sc1) (Fun a2 sc2) = 48 | do ns <- freshRelTo (names sc1) context 49 | let xs = map (Var . Free) ns 50 | return [ Equation (instantiate0 a1) (instantiate0 a2) 51 | , Equation (instantiate sc1 xs) (instantiate sc2 xs) 52 | ] 53 | equate (Lam sc1) (Lam sc2) = 54 | do ns <- freshRelTo (names sc1) context 55 | let xs = map (Var . Free) ns 56 | return [ Equation (instantiate sc1 xs) (instantiate sc2 xs) ] 57 | equate (App f1 a1) (App f2 a2) = 58 | return [ Equation (instantiate0 f1) (instantiate0 f2) 59 | , Equation (instantiate0 a1) (instantiate0 a2) 60 | ] 61 | equate (Con c1 as1) (Con c2 as2) = 62 | do unless (c1 == c2) 63 | $ throwError $ "Mismatching constructors " 64 | ++ c1 ++ " and " ++ c2 65 | unless (length as1 == length as2) 66 | $ throwError $ "Mismatching constructor arg lengths between " 67 | ++ pretty (In (Con c1 as1)) ++ " and " 68 | ++ pretty (In (Con c2 as1)) 69 | return $ zipWith 70 | Equation 71 | (map instantiate0 as1) 72 | (map instantiate0 as2) 73 | equate (Case as1 mot1 cs1) (Case as2 mot2 cs2) = 74 | do unless (length as1 == length as2) 75 | $ throwError $ "Mismatching number of case arguments in " 76 | ++ pretty (In (Case as1 mot1 cs1)) ++ " and " 77 | ++ pretty (In (Case as2 mot2 cs2)) 78 | unless (length cs1 == length cs2) 79 | $ throwError $ "Mismatching number of clauses in " 80 | ++ pretty (In (Case as1 mot1 cs1)) ++ " and " 81 | ++ pretty (In (Case as2 mot2 cs2)) 82 | let argEqs = zipWith 83 | Equation 84 | (map instantiate0 as1) 85 | (map instantiate0 as2) 86 | motEqs <- equateCaseMotive mot1 mot2 87 | clauseEqs <- fmap concat $ zipWithM equateClause cs1 cs2 88 | return $ argEqs ++ motEqs ++ clauseEqs 89 | equate l r = 90 | throwError $ "Cannot unify " ++ pretty (In l) ++ " with " ++ pretty (In r) 91 | 92 | 93 | 94 | 95 | 96 | -- | Equating case motives as a special helper for the main 'equate' method. 97 | 98 | equateCaseMotive :: CaseMotive -> CaseMotive -> Elaborator [Equation Term] 99 | equateCaseMotive mot1@(CaseMotive tele1) mot2@(CaseMotive tele2) = 100 | do ns <- freshRelTo (namesBindingTelescope tele1) context 101 | let xs = map (Var . Free) ns 102 | (as1, b1) = instantiateBindingTelescope tele1 xs 103 | (as2, b2) = instantiateBindingTelescope tele2 xs 104 | unless (length as1 == length as2) 105 | $ throwError $ "Motives not equal: " ++ pretty mot1 ++ " and " 106 | ++ pretty mot2 107 | return $ zipWith Equation as1 as2 ++ [ Equation b1 b2 ] 108 | 109 | 110 | 111 | 112 | 113 | -- Equating clauses as a special helper for the main 'equate' method. 114 | 115 | equateClause :: Clause -> Clause -> Elaborator [Equation Term] 116 | equateClause (Clause pscs1 sc1) (Clause pscs2 sc2) = 117 | do unless (length pscs1 == length pscs2) 118 | $ throwError "Clauses have different numbers of patterns." 119 | unless (length (names sc1) == length (names sc2)) 120 | $ throwError "Patterns bind different numbers of arguments." 121 | ns <- freshRelTo (names sc1) context 122 | let xs = map (Var . Free) ns 123 | xs' = map (Var . Free) ns 124 | ps1 = map (\sc -> patternInstantiate sc xs xs') pscs1 125 | ps2 = map (\sc -> patternInstantiate sc xs xs') pscs2 126 | b1 = instantiate sc1 xs' 127 | b2 = instantiate sc2 xs' 128 | case sequence (zipWith zipABTF ps1 ps2) of 129 | Nothing -> 130 | throwError "Patterns are not equal." 131 | Just pEqss -> 132 | return $ [ Equation a1 a2 | (a1,a2) <- concat pEqss ] 133 | ++ [ Equation b1 b2 ] -------------------------------------------------------------------------------- /src/DependentImplicit/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | module DependentImplicit.Core.ConSig where 10 | 11 | import Utils.ABT 12 | import Utils.Plicity 13 | import Utils.Pretty (pretty) 14 | import Utils.Telescope 15 | import DependentImplicit.Core.DeclArg 16 | import DependentImplicit.Core.Term 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | data ConSig = ConSig [Plicity] (BindingTelescope (Scope TermF)) 25 | 26 | 27 | instance Show ConSig where 28 | show (ConSig plics (BindingTelescope ascs bsc)) = 29 | binders ++ " " ++ pretty (body bsc) 30 | where 31 | binders = 32 | unwords 33 | (zipWith 34 | (\n (plic,a) -> wrap plic (n ++ " : " ++ a)) 35 | ns 36 | (zip plics as)) 37 | as = map (pretty.body) ascs 38 | ns = names bsc 39 | 40 | wrap Expl x = "(" ++ x ++ ")" 41 | wrap Impl x = "{" ++ x ++ "}" 42 | 43 | 44 | conSigH :: [DeclArg] -> Term -> ConSig 45 | conSigH declas b = ConSig plics (bindingTelescopeH xs as b) 46 | where (plics,xas) = unzip [ (plic,(x,a)) | DeclArg plic x a <- declas ] 47 | (xs,as) = unzip xas 48 | 49 | 50 | freeToDefinedConSig :: ConSig -> ConSig 51 | freeToDefinedConSig (ConSig plics tele) = 52 | ConSig plics (fmap (freeToDefinedScope (In . Defined)) tele) -------------------------------------------------------------------------------- /src/DependentImplicit/Core/DeclArg.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | module DependentImplicit.Core.DeclArg where 6 | 7 | import Utils.Plicity 8 | import Utils.Pretty 9 | import DependentImplicit.Core.Term 10 | 11 | 12 | 13 | data DeclArg = DeclArg Plicity String Term 14 | 15 | instance Show DeclArg where 16 | show (DeclArg Expl x t) = "(" ++ x ++ " : " ++ pretty t ++ ")" 17 | show (DeclArg Impl x t) = "{" ++ x ++ " : " ++ pretty t ++ "}" -------------------------------------------------------------------------------- /src/DependentImplicit/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | -- | This module defines how to evaluate terms in the dependently typed lambda 14 | -- calculus. 15 | 16 | module DependentImplicit.Core.Evaluation where 17 | 18 | import Control.Monad.Except 19 | 20 | import Utils.ABT 21 | import Utils.Env 22 | import Utils.Eval 23 | import Utils.Pretty 24 | import Utils.Telescope 25 | import DependentImplicit.Core.Term 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | -- | Because a case expression can be evaluated under a binder, it's necessary 34 | -- to determine when a match failure is real or illusory. For example, if we 35 | -- have the function @\x -> case x of { Zero -> True ; _ -> False }@, and 36 | -- naively tried to match, the first clause would fail, because @x =/= Zero@, 37 | -- and the second would succeed, reducing this function to @\x -> False@. 38 | -- But this would be bad, because if we then applied this function to @Zero@, 39 | -- the result is just @False@. But if we had applied the original function to 40 | -- @Zero@ and evaluated, it would reduce to @True@. Instead, we need to know 41 | -- more than just did the match succeed or fail, but rather, did it succeed, 42 | -- definitely fail because of a constructor mismatch, or is it uncertain 43 | -- because of insufficient information (e.g. a variable or some other 44 | -- non-constructor expression). We can use this type to represent that 45 | -- three-way distinction between definite matches, definite failures, and 46 | -- unknown situations. 47 | 48 | data MatchResult a 49 | = Success a 50 | | Unknown 51 | | Failure 52 | deriving (Functor) 53 | 54 | 55 | instance Applicative MatchResult where 56 | pure = Success 57 | 58 | Success f <*> Success x = Success (f x) 59 | Unknown <*> _ = Unknown 60 | _ <*> Unknown = Unknown 61 | _ <*> _ = Failure 62 | 63 | 64 | instance Monad MatchResult where 65 | return = Success 66 | 67 | Success x >>= f = f x 68 | Unknown >>= _ = Unknown 69 | Failure >>= _ = Failure 70 | 71 | 72 | -- | Pattern matching for case expressions. 73 | 74 | matchPattern :: Pattern -> Term -> MatchResult [Term] 75 | matchPattern (Var _) v = Success [v] 76 | matchPattern (In (ConPat c ps)) (In (Con c' as)) 77 | | c == c' && length ps == length as = 78 | fmap concat 79 | $ forM (zip ps as) 80 | $ \((plic,psc),(plic',asc)) -> 81 | if (plic == plic') 82 | then matchPattern (body psc) (body asc) 83 | else Failure 84 | | otherwise = Failure 85 | matchPattern (In (AssertionPat _)) v = Success [v] 86 | matchPattern _ _ = Unknown 87 | 88 | matchPatterns :: [Pattern] -> [Term] -> MatchResult [Term] 89 | matchPatterns [] [] = 90 | Success [] 91 | matchPatterns (p:ps) (m:ms) = 92 | do vs <- matchPattern p m 93 | vs' <- matchPatterns ps ms 94 | return $ vs ++ vs' 95 | matchPatterns _ _ = Failure 96 | 97 | matchClauses :: [Clause] -> [Term] -> MatchResult Term 98 | matchClauses [] _ = Failure 99 | matchClauses (Clause pscs sc:cs) ms = 100 | case matchPatterns (map patternBody pscs) ms of 101 | Failure -> matchClauses cs ms 102 | Unknown -> Unknown 103 | Success vs -> Success (instantiate sc vs) 104 | 105 | 106 | 107 | 108 | 109 | -- | Standard eager evaluation. 110 | 111 | instance Eval (Env String Term) Term where 112 | eval (Var v) = 113 | return $ Var v 114 | eval (In (Defined x)) = 115 | do env <- environment 116 | case lookup x env of 117 | Nothing -> throwError $ "Unknown constant/defined term: " ++ x 118 | Just m -> eval m 119 | eval (In (Ann m _)) = 120 | eval (instantiate0 m) 121 | eval (In Type) = 122 | return $ In Type 123 | eval (In (Fun plic a sc)) = 124 | do ea <- underF eval a 125 | esc <- underF eval sc 126 | return $ In (Fun plic ea esc) 127 | eval (In (Lam plic sc)) = 128 | do esc <- underF eval sc 129 | return $ In (Lam plic esc) 130 | eval (In (App plic f a)) = 131 | do ef <- eval (instantiate0 f) 132 | ea <- eval (instantiate0 a) 133 | case ef of 134 | In (Lam plic' sc) 135 | | plic == plic' -> eval (instantiate sc [ea]) 136 | | otherwise -> 137 | throwError "Mismatching plicities." 138 | _ -> return $ appH plic ef ea 139 | eval (In (Con c as)) = 140 | do eas <- forM as $ \(plic,a) -> 141 | do ea <- eval (instantiate0 a) 142 | return (plic,ea) 143 | return $ conH c eas 144 | eval (In (Case ms mot cs)) = 145 | do ems <- mapM eval (map instantiate0 ms) 146 | case matchClauses cs ems of 147 | Success b -> eval b 148 | Unknown -> 149 | do emot <- eval mot 150 | return $ caseH ems emot cs 151 | Failure -> 152 | throwError $ "Incomplete pattern match: " 153 | ++ pretty (In (Case ms mot cs)) 154 | 155 | 156 | instance Eval (Env String Term) CaseMotive where 157 | eval (CaseMotive (BindingTelescope ascs bsc)) = 158 | do eascs <- mapM (underF eval) ascs 159 | ebsc <- underF eval bsc 160 | return $ CaseMotive (BindingTelescope eascs ebsc) 161 | 162 | 163 | instance Eval (Env String Term) Clause where 164 | eval (Clause pscs bsc) = 165 | do epscs <- mapM eval pscs 166 | ebsc <- underF eval bsc 167 | return $ Clause epscs ebsc 168 | 169 | 170 | instance Eval (Env String Term) (PatternF (Scope TermF)) where 171 | eval (PatternF x) = 172 | do ex <- underF eval x 173 | return $ PatternF ex 174 | 175 | 176 | instance Eval (Env String Term) (ABT (PatternFF (Scope TermF))) where 177 | eval (Var v) = 178 | return $ Var v 179 | eval (In (ConPat c ps)) = 180 | do eps <- forM ps $ \(plic,p) -> 181 | do ep <- underF eval p 182 | return (plic,ep) 183 | return $ In (ConPat c eps) 184 | eval (In (AssertionPat m)) = 185 | do em <- underF eval m 186 | return $ In (AssertionPat em) 187 | eval (In MakeMeta) = 188 | return $ In MakeMeta -------------------------------------------------------------------------------- /src/DependentImplicit/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module defines what it means to be a program in the dependently 10 | -- typed lambda calculus. 11 | 12 | module DependentImplicit.Core.Program where 13 | 14 | import Utils.Plicity 15 | import Utils.Pretty 16 | import DependentImplicit.Core.ConSig 17 | import DependentImplicit.Core.DeclArg 18 | import DependentImplicit.Core.Term 19 | 20 | import Data.List (intercalate) 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | -- | A program is just a series of 'Statement's. 29 | 30 | newtype Program = Program [Statement] 31 | 32 | instance Show Program where 33 | show (Program stmts) = intercalate "\n\n" (map show stmts) 34 | 35 | 36 | 37 | 38 | 39 | -- | A 'Statement' is either a 'TypeDeclaration' or a 'TermDeclaration'. 40 | 41 | data Statement 42 | = TyDecl TypeDeclaration 43 | | TmDecl TermDeclaration 44 | 45 | instance Show Statement where 46 | show (TyDecl td) = show td 47 | show (TmDecl td) = show td 48 | 49 | 50 | 51 | 52 | 53 | -- | A term can be declared either with a simple equality, as in 54 | -- 55 | -- > let not : Bool -> Bool 56 | -- > = \b -> case b of 57 | -- > | True -> False 58 | -- > | False -> True 59 | -- > end 60 | -- > end 61 | -- 62 | -- or with a pattern match, as in 63 | -- 64 | -- > let not : Bool -> Bool where 65 | -- > | not True = False 66 | -- > | not False = True 67 | -- > end 68 | 69 | data TermDeclaration 70 | = TermDeclaration String Term Term 71 | | WhereDeclaration String Term [([Plicity],([String],[Pattern],Term))] 72 | 73 | instance Show TermDeclaration where 74 | show (TermDeclaration n ty def) = 75 | "let " ++ n ++ " : " ++ pretty ty ++ " = " ++ pretty def ++ " end" 76 | show (WhereDeclaration n ty preclauses) 77 | = "let " ++ n ++ " : " ++ pretty ty ++ " where " 78 | ++ intercalate " | " (map showPreclause preclauses) 79 | where 80 | showPreclause :: ([Plicity],([String],[Pattern],Term)) -> String 81 | showPreclause (plics,(_,ps,b)) 82 | = intercalate 83 | " || " 84 | (map showPattern (zip plics ps)) 85 | ++ " -> " ++ pretty b 86 | 87 | showPattern :: (Plicity,Pattern) -> String 88 | showPattern (Expl,p) = parenthesize (Just (ConPatArg Expl)) p 89 | showPattern (Impl,p) = parenthesize (Just (ConPatArg Impl)) p 90 | 91 | 92 | 93 | 94 | 95 | -- | A type is declared with a GADT-like notation, however instead of giving 96 | -- the type of a constructor, as in Haskell or Agda, a constructor's signature 97 | -- is given via exemplified application, as in: 98 | -- 99 | -- @ 100 | -- data List (a : Type) where 101 | -- | Nil : List a 102 | -- | Cons (x : a) (xs : List a) : List a 103 | -- end 104 | -- @ 105 | -- 106 | -- Types with no constructors need no @where@: 107 | -- 108 | -- > data Void end 109 | 110 | data TypeDeclaration 111 | = TypeDeclaration String [DeclArg] [(String,ConSig)] 112 | 113 | instance Show TypeDeclaration where 114 | show (TypeDeclaration tycon tyargs []) = 115 | "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 116 | show (TypeDeclaration tycon tyargs alts) = 117 | "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " where" 118 | ++ concat [ "\n" ++ c ++ " : " ++ show sig | (c,sig) <- alts ] 119 | ++ "\nend" -------------------------------------------------------------------------------- /src/DependentImplicit/Demo.sfp: -------------------------------------------------------------------------------- 1 | data Inv {a : Type} {b : Type} (f : (x : a) -> b) (y : b) where 2 | | InvEl {a : Type} {b : Type} {f : (x : a) -> b} (x : a) : Inv f (f x) 3 | end 4 | 5 | data Bool where 6 | | True : Bool 7 | | False : Bool 8 | end 9 | 10 | let not : (b : Bool) -> Bool 11 | = \b -> case b 12 | motive (b' : Bool) || Bool 13 | of 14 | | True -> False 15 | | False -> True 16 | end 17 | end 18 | 19 | let ex : Inv not True 20 | = InvEl False 21 | end 22 | 23 | data Nat where 24 | | Zero : Nat 25 | | Suc (n : Nat) : Nat 26 | end 27 | 28 | let plusOne : (n : Nat) -> Nat 29 | = \n -> Suc n 30 | end 31 | 32 | let ex2 : Inv plusOne (Suc Zero) 33 | = InvEl Zero 34 | end 35 | 36 | let natInd : (p : (n : Nat) -> Type) -> (z : p Zero) -> (s : (n : Nat) -> (r : p n) -> p (Suc n)) -> (n : Nat) -> p n 37 | = \p -> \z -> \s -> \n -> 38 | case n 39 | motive (n' : Nat) || p n' 40 | of 41 | | Zero -> z 42 | | Suc n' -> s n' (natInd p z s n') 43 | end 44 | end 45 | 46 | data Vec (a : Type) (n : Nat) where 47 | | Nil {a : Type} : Vec a Zero 48 | | Cons {a : Type} {n : Nat} (x : a) (xs : Vec a n) : Vec a (Suc n) 49 | end 50 | 51 | let vapp : {a : Type} -> {b : Type} -> {n : Nat} -> (fs : Vec ((x : a) -> b) n) -> (xs : Vec a n) -> Vec b n 52 | = \{a} -> \{b} -> \{n} -> \fs -> \xs -> 53 | case n || fs || xs 54 | motive (n' : Nat) || (fs' : Vec ((x : a) -> b) n') || (xs' : Vec a n') || Vec b n' 55 | of 56 | | Zero || Nil || Nil -> Nil 57 | | Suc n' || Cons f fs' || Cons x xs' -> Cons (f x) (vapp fs' xs') 58 | end 59 | end 60 | 61 | let vec : {a : Type} -> {n : Nat} -> (x : a) -> Vec a n 62 | = \{a} -> \{n} -> \x -> 63 | case n 64 | motive (n' : Nat) || Vec a n' 65 | of 66 | | Zero -> Nil 67 | | Suc n' -> Cons x (vec x) 68 | end 69 | end 70 | 71 | let ex3 : Vec Bool (Suc (Suc (Suc Zero))) 72 | = vec True 73 | end 74 | 75 | data Im (p : Bool -> Type) (b : Bool) where 76 | | MkIm {p : Bool -> Type} {b : Bool} (x : p b) : Im p b 77 | end 78 | 79 | let ifT : Type -> Type -> Bool -> Type where 80 | | ifT a b True = a 81 | | ifT a b False = b 82 | end 83 | 84 | data Top where Unit : Top end 85 | 86 | data Bot end 87 | 88 | let ex4 : Im (ifT Top Bot) True 89 | = MkIm Unit 90 | end 91 | 92 | let ex5 : Im (ifT Top Bot) True 93 | = MkIm (((\x -> x) : Top -> Top) Unit) 94 | end 95 | 96 | let plus : Nat -> Nat -> Nat where 97 | | plus Zero n = n 98 | | plus (Suc m) n = Suc (plus m n) 99 | end 100 | 101 | let append : {a : Type} -> {m : Nat} -> {n : Nat} 102 | -> (xs : Vec a m) -> (ys : Vec a n) -> Vec a (plus m n) 103 | = \{a} -> \{m} -> \{n} -> \xs -> \ys -> 104 | case m || xs 105 | motive (m' : Nat) || (xs' : Vec a m') || Vec a (plus m' n) 106 | of 107 | | Zero || Nil -> ys 108 | | Suc m' || Cons x xs' -> Cons x (append xs' ys) 109 | end 110 | end -------------------------------------------------------------------------------- /src/DependentImplicit/Unification/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -- This module defines the core types of a monadic elaborator. 12 | 13 | module DependentImplicit.Unification.Elaborator where 14 | 15 | import Utils.Env 16 | import Utils.Unifier 17 | import Utils.Vars 18 | import DependentImplicit.Core.ConSig 19 | import DependentImplicit.Core.Term 20 | 21 | import qualified Control.Lens as L 22 | import Control.Monad.State 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | -- | A signature is a collection of constructors together with their 31 | -- constructor signatures. This is used during type checking and elaboration 32 | -- to define the underlying type theory. 33 | 34 | type Signature = [(String,ConSig)] 35 | 36 | 37 | 38 | 39 | 40 | -- | A definition consists of a declared name together with its definition 41 | -- and its type. 42 | 43 | type Definitions = [(String,(Term,Term))] 44 | 45 | definitionsToEnvironment :: Definitions -> Env String Term 46 | definitionsToEnvironment defs = 47 | [ (x,m) | (x,(m,_)) <- defs ] 48 | 49 | 50 | 51 | 52 | 53 | -- | A context contains generated variables together with their display names, 54 | -- and their declared types. 55 | 56 | type Context = [(FreeVar,Term)] 57 | 58 | 59 | 60 | 61 | 62 | -- | The definition of the state to be carried by the type checking monad for 63 | -- this particular variant. 64 | 65 | data ElabState 66 | = ElabState 67 | { _signature :: Signature 68 | , _definitions :: Definitions 69 | , _context :: Context 70 | , _substitution :: Substitution TermF 71 | , _nextMeta :: MetaVar 72 | } 73 | L.makeLenses ''ElabState 74 | 75 | 76 | type Elaborator = StateT ElabState (Either String) 77 | 78 | 79 | type TypeChecker = Elaborator 80 | 81 | 82 | runElaborator :: Elaborator a 83 | -> Signature 84 | -> Definitions 85 | -> Context 86 | -> Either String (a,ElabState) 87 | runElaborator e sig defs ctx = 88 | runStateT e (ElabState sig defs ctx [] (MetaVar 0)) 89 | 90 | 91 | runElaborator0 :: Elaborator a -> Either String (a,ElabState) 92 | runElaborator0 e = runElaborator e [] [] [] 93 | 94 | 95 | when' :: Elaborator a -> Elaborator () -> Elaborator () 96 | when' e1 e2 = do s <- get 97 | case runStateT e1 s of 98 | Left _ -> return () 99 | Right _ -> e2 -------------------------------------------------------------------------------- /src/DependentImplicit/Unification/REPL.hs: -------------------------------------------------------------------------------- 1 | module DependentImplicit.Unification.REPL where 2 | 3 | import Control.Monad.Reader (runReaderT) 4 | import System.IO 5 | 6 | import Utils.ABT 7 | import Utils.Env 8 | import Utils.Eval 9 | import Utils.Pretty 10 | import DependentImplicit.Core.ConSig 11 | import DependentImplicit.Core.Evaluation 12 | import DependentImplicit.Core.Parser 13 | import DependentImplicit.Core.Term 14 | import DependentImplicit.Unification.Elaborator 15 | import DependentImplicit.Unification.Elaboration 16 | import DependentImplicit.Unification.TypeChecking 17 | 18 | 19 | 20 | flushStr :: String -> IO () 21 | flushStr str = putStr str >> hFlush stdout 22 | 23 | readPrompt :: String -> IO String 24 | readPrompt prompt = flushStr prompt >> getLine 25 | 26 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 27 | until_ p prompt action = do 28 | result <- prompt 29 | if p result 30 | then return () 31 | else action result >> until_ p prompt action 32 | 33 | repl :: String -> IO () 34 | repl src = case loadProgram src of 35 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 36 | Right (sig,defs,ctx,env) 37 | -> do hSetBuffering stdin LineBuffering 38 | until_ (== ":quit") 39 | (readPrompt "$> ") 40 | (evalAndPrint sig defs ctx env) 41 | where 42 | loadProgram :: String -> Either String (Signature,Definitions,Context,Env String Term) 43 | loadProgram src 44 | = do prog <- parseProgram src 45 | (_,ElabState sig defs ctx _ _) <- runElaborator0 (elabProgram prog) 46 | let env = definitionsToEnvironment defs 47 | return (sig,defs,ctx,env) 48 | 49 | loadTerm :: Signature -> Definitions -> Context -> Env String Term -> String -> Either String Term 50 | loadTerm sig defs ctx env src 51 | = do tm0 <- parseTerm src 52 | let tm = freeToDefined (In . Defined) tm0 53 | case runElaborator (infer tm) sig defs ctx of 54 | Left e -> Left e 55 | Right ((etm,_),_) -> runReaderT (eval etm) env 56 | 57 | evalAndPrint :: Signature -> Definitions -> Context -> Env String Term -> String -> IO () 58 | evalAndPrint _ _ _ _ "" = return () 59 | evalAndPrint sig defs ctx env src 60 | = case loadTerm sig defs ctx env src of 61 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 62 | Right v -> flushStr (pretty v ++ "\n") 63 | 64 | replFile :: String -> IO () 65 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/DependentImplicit/Unification/Unification.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -- | This module defines unification of dependent types. 15 | 16 | module DependentImplicit.Unification.Unification where 17 | 18 | import Utils.ABT 19 | import Utils.Elaborator 20 | import Utils.Pretty 21 | import Utils.Telescope 22 | import Utils.Unifier 23 | import DependentImplicit.Core.Term 24 | import DependentImplicit.Unification.Elaborator 25 | 26 | import Control.Monad.Except 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | -- | Equating terms by trivial structural equations. 35 | 36 | instance MonadUnify TermF Elaborator where 37 | equate (Defined n1) (Defined n2) = 38 | if n1 == n2 39 | then return [] 40 | else throwError $ "Mismatching names " ++ n1 ++ " and " ++ n2 41 | equate (Ann m1 t1) (Ann m2 t2) = 42 | return [ Equation (instantiate0 m1) (instantiate0 m2) 43 | , Equation (instantiate0 t1) (instantiate0 t2) 44 | ] 45 | equate Type Type = 46 | return [] 47 | equate (Fun plic1 a1 sc1) (Fun plic2 a2 sc2) = 48 | do unless (plic1 == plic2) 49 | $ throwError $ "Mismatching plicities when unifying " 50 | ++ pretty (In (Fun plic1 a1 sc1)) ++ " with " 51 | ++ pretty (In (Fun plic2 a2 sc2)) 52 | ns <- freshRelTo (names sc1) context 53 | let xs = map (Var . Free) ns 54 | return [ Equation (instantiate0 a1) (instantiate0 a2) 55 | , Equation (instantiate sc1 xs) (instantiate sc2 xs) 56 | ] 57 | equate (Lam plic1 sc1) (Lam plic2 sc2) = 58 | do unless (plic1 == plic2) 59 | $ throwError $ "Mismatching plicities when unifying " 60 | ++ pretty (In (Lam plic1 sc1)) ++ " with " 61 | ++ pretty (In (Lam plic2 sc2)) 62 | ns <- freshRelTo (names sc1) context 63 | let xs = map (Var . Free) ns 64 | return [ Equation (instantiate sc1 xs) (instantiate sc2 xs) ] 65 | equate (App plic1 f1 a1) (App plic2 f2 a2) = 66 | do unless (plic1 == plic2) 67 | $ throwError $ "Mismatching plicities when unifying " 68 | ++ pretty (In (App plic1 f1 a1)) ++ " with " 69 | ++ pretty (In (App plic2 f2 a2)) 70 | return [ Equation (instantiate0 f1) (instantiate0 f2) 71 | , Equation (instantiate0 a1) (instantiate0 a2) 72 | ] 73 | equate (Con c1 as1) (Con c2 as2) = 74 | do unless (c1 == c2) 75 | $ throwError $ "Mismatching constructors " 76 | ++ c1 ++ " and " ++ c2 77 | unless (length as1 == length as2) 78 | $ throwError $ "Mismatching constructor arg lengths between " 79 | ++ pretty (In (Con c1 as1)) ++ " and " 80 | ++ pretty (In (Con c2 as1)) 81 | let (plics1,as1') = unzip as1 82 | (plics2,as2') = unzip as2 83 | unless (plics1 == plics2) 84 | $ throwError $ "Mismatching plicities when unifying " 85 | ++ pretty (In (Con c1 as1)) ++ " with " 86 | ++ pretty (In (Con c2 as2)) 87 | return $ zipWith 88 | Equation 89 | (map instantiate0 as1') 90 | (map instantiate0 as2') 91 | equate (Case as1 mot1 cs1) (Case as2 mot2 cs2) = 92 | do unless (length as1 == length as2) 93 | $ throwError $ "Mismatching number of case arguments in " 94 | ++ pretty (In (Case as1 mot1 cs1)) ++ " and " 95 | ++ pretty (In (Case as2 mot2 cs2)) 96 | unless (length cs1 == length cs2) 97 | $ throwError $ "Mismatching number of clauses in " 98 | ++ pretty (In (Case as1 mot1 cs1)) ++ " and " 99 | ++ pretty (In (Case as2 mot2 cs2)) 100 | let argEqs = zipWith 101 | Equation 102 | (map instantiate0 as1) 103 | (map instantiate0 as2) 104 | motEqs <- equateCaseMotive mot1 mot2 105 | clauseEqs <- fmap concat $ zipWithM equateClause cs1 cs2 106 | return $ argEqs ++ motEqs ++ clauseEqs 107 | equate l r = 108 | throwError $ "Cannot unify " ++ pretty (In l) ++ " with " ++ pretty (In r) 109 | 110 | 111 | 112 | 113 | 114 | -- | Equating case motives as a special helper for the main 'equate' method. 115 | 116 | equateCaseMotive :: CaseMotive -> CaseMotive -> Elaborator [Equation Term] 117 | equateCaseMotive mot1@(CaseMotive tele1) mot2@(CaseMotive tele2) = 118 | do ns <- freshRelTo (namesBindingTelescope tele1) context 119 | let xs = map (Var . Free) ns 120 | (as1, b1) = instantiateBindingTelescope tele1 xs 121 | (as2, b2) = instantiateBindingTelescope tele2 xs 122 | unless (length as1 == length as2) 123 | $ throwError $ "Motives not equal: " ++ pretty mot1 ++ " and " 124 | ++ pretty mot2 125 | return $ zipWith Equation as1 as2 ++ [ Equation b1 b2 ] 126 | 127 | 128 | 129 | 130 | 131 | -- Equating clauses as a special helper for the main 'equate' method. 132 | 133 | equateClause :: Clause -> Clause -> Elaborator [Equation Term] 134 | equateClause (Clause pscs1 sc1) (Clause pscs2 sc2) = 135 | do unless (length pscs1 == length pscs2) 136 | $ throwError "Clauses have different numbers of patterns." 137 | unless (length (names sc1) == length (names sc2)) 138 | $ throwError "Patterns bind different numbers of arguments." 139 | ns <- freshRelTo (names sc1) context 140 | let xs = map (Var . Free) ns 141 | xs' = map (Var . Free) ns 142 | ps1 = map (\sc -> patternInstantiate sc xs xs') pscs1 143 | ps2 = map (\sc -> patternInstantiate sc xs xs') pscs2 144 | b1 = instantiate sc1 xs' 145 | b2 = instantiate sc2 xs' 146 | case sequence (zipWith zipABTF ps1 ps2) of 147 | Nothing -> 148 | throwError "Patterns are not equal." 149 | Just pEqss -> 150 | return $ [ Equation a1 a2 | (a1,a2) <- concat pEqss ] 151 | ++ [ Equation b1 b2 ] -------------------------------------------------------------------------------- /src/Modular/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | module Modular.Core.ConSig where 10 | 11 | import Utils.ABT 12 | import Utils.Names 13 | import Utils.Plicity 14 | import Utils.Pretty (pretty) 15 | import Utils.Telescope 16 | import Modular.Core.DeclArg 17 | import Modular.Core.Term 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | data ConSig = ConSig [Plicity] (BindingTelescope (Scope TermF)) 26 | 27 | 28 | instance Show ConSig where 29 | show (ConSig plics (BindingTelescope ascs bsc)) = 30 | binders ++ " " ++ pretty (body bsc) 31 | where 32 | binders = 33 | unwords 34 | (zipWith 35 | (\n (plic,a) -> wrap plic (n ++ " : " ++ a)) 36 | ns 37 | (zip plics as)) 38 | as = map (pretty.body) ascs 39 | ns = names bsc 40 | 41 | wrap Expl x = "(" ++ x ++ ")" 42 | wrap Impl x = "{" ++ x ++ "}" 43 | 44 | 45 | conSigH :: [DeclArg] -> Term -> ConSig 46 | conSigH declas b = ConSig plics (bindingTelescopeH xs as b) 47 | where (plics,xas) = unzip [ (plic,(x,a)) | DeclArg plic x a <- declas ] 48 | (xs,as) = unzip xas 49 | 50 | 51 | freeToDefinedConSig :: ConSig -> ConSig 52 | freeToDefinedConSig (ConSig plics tele) = 53 | ConSig plics (fmap (freeToDefinedScope (In . Defined . BareLocal)) tele) -------------------------------------------------------------------------------- /src/Modular/Core/DeclArg.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | module Modular.Core.DeclArg where 6 | 7 | import Utils.Plicity 8 | import Utils.Pretty 9 | import Modular.Core.Term 10 | 11 | 12 | 13 | data DeclArg = DeclArg Plicity String Term 14 | 15 | instance Show DeclArg where 16 | show (DeclArg Expl x t) = "(" ++ x ++ " : " ++ pretty t ++ ")" 17 | show (DeclArg Impl x t) = "{" ++ x ++ " : " ++ pretty t ++ "}" -------------------------------------------------------------------------------- /src/Modular/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | -- | This module defines how to evaluate terms in the dependently typed lambda 14 | -- calculus. 15 | 16 | module Modular.Core.Evaluation where 17 | 18 | import Control.Monad.Except 19 | 20 | import Utils.ABT 21 | import Utils.Env 22 | import Utils.Eval 23 | import Utils.Names 24 | import Utils.Pretty 25 | import Utils.Telescope 26 | import Modular.Core.Term 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | -- | Because a case expression can be evaluated under a binder, it's necessary 35 | -- to determine when a match failure is real or illusory. For example, if we 36 | -- have the function @\x -> case x of { Zero -> True ; _ -> False }@, and 37 | -- naively tried to match, the first clause would fail, because @x =/= Zero@, 38 | -- and the second would succeed, reducing this function to @\x -> False@. 39 | -- But this would be bad, because if we then applied this function to @Zero@, 40 | -- the result is just @False@. But if we had applied the original function to 41 | -- @Zero@ and evaluated, it would reduce to @True@. Instead, we need to know 42 | -- more than just did the match succeed or fail, but rather, did it succeed, 43 | -- definitely fail because of a constructor mismatch, or is it uncertain 44 | -- because of insufficient information (e.g. a variable or some other 45 | -- non-constructor expression). We can use this type to represent that 46 | -- three-way distinction between definite matches, definite failures, and 47 | -- unknown situations. 48 | 49 | data MatchResult a 50 | = Success a 51 | | Unknown 52 | | Failure 53 | deriving (Functor) 54 | 55 | 56 | instance Applicative MatchResult where 57 | pure = Success 58 | 59 | Success f <*> Success x = Success (f x) 60 | Unknown <*> _ = Unknown 61 | _ <*> Unknown = Unknown 62 | _ <*> _ = Failure 63 | 64 | 65 | instance Monad MatchResult where 66 | return = Success 67 | 68 | Success x >>= f = f x 69 | Unknown >>= _ = Unknown 70 | Failure >>= _ = Failure 71 | 72 | 73 | -- | Pattern matching for case expressions. 74 | 75 | matchPattern :: Pattern -> Term -> MatchResult [Term] 76 | matchPattern (Var _) v = Success [v] 77 | matchPattern (In (ConPat c ps)) (In (Con c' as)) 78 | | c == c' && length ps == length as = 79 | fmap concat 80 | $ forM (zip ps as) 81 | $ \((plic,psc),(plic',asc)) -> 82 | if (plic == plic') 83 | then matchPattern (body psc) (body asc) 84 | else Failure 85 | | otherwise = Failure 86 | matchPattern (In (AssertionPat _)) v = Success [v] 87 | matchPattern _ _ = Unknown 88 | 89 | matchPatterns :: [Pattern] -> [Term] -> MatchResult [Term] 90 | matchPatterns [] [] = 91 | Success [] 92 | matchPatterns (p:ps) (m:ms) = 93 | do vs <- matchPattern p m 94 | vs' <- matchPatterns ps ms 95 | return $ vs ++ vs' 96 | matchPatterns _ _ = Failure 97 | 98 | matchClauses :: [Clause] -> [Term] -> MatchResult Term 99 | matchClauses [] _ = Failure 100 | matchClauses (Clause pscs sc:cs) ms = 101 | case matchPatterns (map patternBody pscs) ms of 102 | Failure -> matchClauses cs ms 103 | Unknown -> Unknown 104 | Success vs -> Success (instantiate sc vs) 105 | 106 | 107 | 108 | 109 | 110 | -- | Standard eager evaluation. 111 | 112 | type EnvKey = (String,String) 113 | 114 | instance Eval (Env EnvKey Term) Term where 115 | eval (Var v) = 116 | return $ Var v 117 | eval (In (Defined (Absolute m n))) = 118 | do env <- environment 119 | case lookup (m,n) env of 120 | Nothing -> throwError $ "Unknown constant/defined term: " 121 | ++ showName (Absolute m n) 122 | Just x -> eval x 123 | eval (In (Defined x)) = 124 | throwError $ "Cannot evaluate the local name " ++ showName x 125 | eval (In (Ann m _)) = 126 | eval (instantiate0 m) 127 | eval (In Type) = 128 | return $ In Type 129 | eval (In (Fun plic a sc)) = 130 | do ea <- underF eval a 131 | esc <- underF eval sc 132 | return $ In (Fun plic ea esc) 133 | eval (In (Lam plic sc)) = 134 | do esc <- underF eval sc 135 | return $ In (Lam plic esc) 136 | eval (In (App plic f a)) = 137 | do ef <- eval (instantiate0 f) 138 | ea <- eval (instantiate0 a) 139 | case ef of 140 | In (Lam plic' sc) 141 | | plic == plic' -> eval (instantiate sc [ea]) 142 | | otherwise -> 143 | throwError "Mismatching plicities." 144 | _ -> return $ appH plic ef ea 145 | eval (In (Con c as)) = 146 | do eas <- forM as $ \(plic,a) -> 147 | do ea <- eval (instantiate0 a) 148 | return (plic,ea) 149 | return $ conH c eas 150 | eval (In (Case ms mot cs)) = 151 | do ems <- mapM eval (map instantiate0 ms) 152 | case matchClauses cs ems of 153 | Success b -> eval b 154 | Unknown -> 155 | do emot <- eval mot 156 | return $ caseH ems emot cs 157 | Failure -> 158 | throwError $ "Incomplete pattern match: " 159 | ++ pretty (In (Case ms mot cs)) 160 | 161 | 162 | instance Eval (Env EnvKey Term) CaseMotive where 163 | eval (CaseMotive (BindingTelescope ascs bsc)) = 164 | do eascs <- mapM (underF eval) ascs 165 | ebsc <- underF eval bsc 166 | return $ CaseMotive (BindingTelescope eascs ebsc) 167 | 168 | 169 | instance Eval (Env EnvKey Term) Clause where 170 | eval (Clause pscs bsc) = 171 | do epscs <- mapM eval pscs 172 | ebsc <- underF eval bsc 173 | return $ Clause epscs ebsc 174 | 175 | 176 | instance Eval (Env EnvKey Term) (PatternF (Scope TermF)) where 177 | eval (PatternF x) = 178 | do ex <- underF eval x 179 | return $ PatternF ex 180 | 181 | 182 | instance Eval (Env EnvKey Term) (ABT (PatternFF (Scope TermF))) where 183 | eval (Var v) = 184 | return $ Var v 185 | eval (In (ConPat c ps)) = 186 | do eps <- forM ps $ \(plic,p) -> 187 | do ep <- underF eval p 188 | return (plic,ep) 189 | return $ In (ConPat c eps) 190 | eval (In (AssertionPat m)) = 191 | do em <- underF eval m 192 | return $ In (AssertionPat em) 193 | eval (In MakeMeta) = 194 | return $ In MakeMeta -------------------------------------------------------------------------------- /src/Modular/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module defines what it means to be a program in the dependently 10 | -- typed lambda calculus. 11 | 12 | module Modular.Core.Program where 13 | 14 | import Utils.Plicity 15 | import Utils.Pretty 16 | import Modular.Core.ConSig 17 | import Modular.Core.DeclArg 18 | import Modular.Core.Term 19 | 20 | import Data.List (intercalate) 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | -- | A 'Statement' is either a 'TypeDeclaration' or a 'TermDeclaration'. 29 | 30 | data Statement 31 | = TyDecl TypeDeclaration 32 | | TmDecl TermDeclaration 33 | 34 | instance Show Statement where 35 | show (TyDecl td) = show td 36 | show (TmDecl td) = show td 37 | 38 | 39 | 40 | 41 | 42 | -- | A term can be declared either with a simple equality, as in 43 | -- 44 | -- > let not : Bool -> Bool 45 | -- > = \b -> case b of 46 | -- > | True -> False 47 | -- > | False -> True 48 | -- > end 49 | -- > end 50 | -- 51 | -- or with a pattern match, as in 52 | -- 53 | -- > let not : Bool -> Bool where 54 | -- > | not True = False 55 | -- > | not False = True 56 | -- > end 57 | 58 | data TermDeclaration 59 | = TermDeclaration String Term Term 60 | | WhereDeclaration String Term [([Plicity],([String],[Pattern],Term))] 61 | 62 | instance Show TermDeclaration where 63 | show (TermDeclaration n ty def) = 64 | "let " ++ n ++ " : " ++ pretty ty ++ " = " ++ pretty def ++ " end" 65 | show (WhereDeclaration n ty preclauses) 66 | = "let " ++ n ++ " : " ++ pretty ty ++ " where " 67 | ++ intercalate " | " (map showPreclause preclauses) 68 | where 69 | showPreclause :: ([Plicity],([String],[Pattern],Term)) -> String 70 | showPreclause (plics,(_,ps,b)) 71 | = intercalate 72 | " || " 73 | (map showPattern (zip plics ps)) 74 | ++ " -> " ++ pretty b 75 | 76 | showPattern :: (Plicity,Pattern) -> String 77 | showPattern (Expl,p) = parenthesize (Just (ConPatArg Expl)) p 78 | showPattern (Impl,p) = parenthesize (Just (ConPatArg Impl)) p 79 | 80 | 81 | 82 | 83 | 84 | -- | A type is declared with a GADT-like notation, however instead of giving 85 | -- the type of a constructor, as in Haskell or Agda, a constructor's signature 86 | -- is given via exemplified application, as in: 87 | -- 88 | -- @ 89 | -- data List (a : Type) where 90 | -- | Nil : List a 91 | -- | Cons (x : a) (xs : List a) : List a 92 | -- end 93 | -- @ 94 | -- 95 | -- Types with no constructors need no @where@: 96 | -- 97 | -- > data Void end 98 | 99 | data TypeDeclaration 100 | = TypeDeclaration String [DeclArg] [(String,ConSig)] 101 | 102 | instance Show TypeDeclaration where 103 | show (TypeDeclaration tycon tyargs []) = 104 | "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 105 | show (TypeDeclaration tycon tyargs alts) = 106 | "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " where" 107 | ++ concat [ "\n" ++ c ++ " : " ++ show sig | (c,sig) <- alts ] 108 | ++ "\nend" 109 | 110 | 111 | 112 | 113 | 114 | -- | Settings for hiding or using names from a module. 115 | 116 | data HidingUsing 117 | = Hiding [String] 118 | | Using [String] 119 | 120 | 121 | 122 | 123 | 124 | -- | Settings for opening a module's names for use. 125 | 126 | data OpenSettings 127 | = OpenSettings 128 | { openModule :: String 129 | , openAs :: Maybe String 130 | , openHidingUsing :: Maybe HidingUsing 131 | , openRenaming :: [(String,String)] 132 | } 133 | 134 | instance Show OpenSettings where 135 | show (OpenSettings m a hu r) 136 | = m ++ a' ++ hu' ++ r' 137 | where 138 | a' = case a of 139 | Nothing -> "" 140 | Just m' -> " as " ++ m' 141 | hu' = case hu of 142 | Nothing -> "" 143 | Just (Hiding ns) -> " hiding (" ++ intercalate "," ns ++ ")" 144 | Just (Using ns) -> " using (" ++ intercalate "," ns ++ ")" 145 | r' = case r of 146 | [] -> "" 147 | _ -> " renaming (" 148 | ++ intercalate 149 | ", " 150 | [ n ++ " to " ++ n' 151 | | (n,n') <- r 152 | ] 153 | ++ ")" 154 | 155 | 156 | 157 | 158 | 159 | -- | Modules with imports of other modules. 160 | 161 | data Module 162 | = Module String [OpenSettings] [Statement] 163 | 164 | instance Show Module where 165 | show (Module n [] stmts) 166 | = "module " ++ n ++ " where\n\n" 167 | ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 168 | show (Module n settings stmts) 169 | = "module " ++ n ++ " opening " ++ intercalate " | " (map show settings) 170 | ++ " where\n\n" ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 171 | 172 | 173 | 174 | 175 | 176 | -- | A program is just a series of 'Module's. 177 | 178 | newtype Program = Program [Module] 179 | 180 | instance Show Program where 181 | show (Program stmts) = intercalate "\n\n" (map show stmts) -------------------------------------------------------------------------------- /src/Modular/Demo.sfp: -------------------------------------------------------------------------------- 1 | module Nat where 2 | 3 | data Nat where 4 | | Zero : Nat 5 | | Suc (n : Nat) : Nat 6 | end 7 | 8 | let plus : (m : Nat) -> (n : Nat) -> Nat 9 | = \m -> \n -> 10 | case m 11 | motive (m' : Nat) || Nat 12 | of 13 | | Zero -> n 14 | | Suc m' -> Suc (plus m' n) 15 | end 16 | end 17 | 18 | end 19 | 20 | 21 | module Vec1 opening Nat where 22 | 23 | data Vec (a : Type) (n : Nat) where 24 | | Nil {a : Type} : Vec a Zero 25 | | Cons {a : Type} {n : Nat} (x : a) (xs : Vec a n) : Vec a (Suc n) 26 | end 27 | 28 | end 29 | 30 | 31 | module Vec2 opening Nat as N where 32 | 33 | data Vec (a : Type) (n : N.Nat) where 34 | | Nil {a : Type} : Vec a N.Zero 35 | | Cons {a : Type} {n : N.Nat} (x : a) (xs : Vec a n) : Vec a (N.Suc n) 36 | end 37 | 38 | end 39 | 40 | 41 | module Vec3 42 | opening 43 | | Nat renaming (Zero to Z, Suc to S) 44 | where 45 | 46 | data Vec (a : Type) (n : Nat) where 47 | | Nil {a : Type} : Vec a Z 48 | | Cons {a : Type} {n : Nat} (x : a) (xs : Vec a n) : Vec a (S n) 49 | end 50 | 51 | end 52 | 53 | 54 | module VecAppend1 opening Vec1 | Nat where 55 | 56 | let append : {a : Type} -> {m : Nat} -> {n : Nat} 57 | -> (xs : Vec a m) -> (ys : Vec a n) -> Vec a (plus m n) 58 | = \{a} -> \{m} -> \{n} -> \xs -> \ys -> 59 | case m || xs 60 | motive (m' : Nat) || (xs' : Vec a m') || Vec a (plus m' n) 61 | of 62 | | Zero || Nil -> ys 63 | | Suc m' || Cons x xs' -> Cons x (append xs' ys) 64 | end 65 | end 66 | 67 | end -------------------------------------------------------------------------------- /src/Modular/Unification/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -- This module defines the core types of a monadic elaborator. 12 | 13 | module Modular.Unification.Elaborator where 14 | 15 | import Utils.Env 16 | import Utils.Unifier 17 | import Utils.Vars 18 | import Modular.Core.ConSig 19 | import Modular.Core.Term 20 | 21 | import qualified Control.Lens as L 22 | import Control.Monad.State 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | -- | A signature is a collection of constructors together with their 31 | -- constructor signatures. This is used during type checking and elaboration 32 | -- to define the underlying type theory. 33 | 34 | type Signature = [((String,String),ConSig)] 35 | 36 | 37 | 38 | 39 | 40 | -- | A definition consists of a declared name together with its definition 41 | -- and its type. 42 | 43 | type Definitions = [((String,String),(Term,Term))] 44 | 45 | definitionsToEnvironment :: Definitions -> Env (String,String) Term 46 | definitionsToEnvironment defs = 47 | [ (x,m) | (x,(m,_)) <- defs ] 48 | 49 | 50 | 51 | 52 | 53 | -- | A context contains generated variables together with their display names, 54 | -- and their declared types. 55 | 56 | type Context = [(FreeVar,Term)] 57 | 58 | 59 | 60 | 61 | 62 | -- | Aliases are just maps from local names to absolute names. 63 | 64 | type Aliases = [(Either String (String,String), (String,String))] 65 | 66 | 67 | 68 | 69 | 70 | -- | The definition of the state to be carried by the type checking monad for 71 | -- this particular variant. 72 | 73 | data ElabState 74 | = ElabState 75 | { _signature :: Signature 76 | , _definitions :: Definitions 77 | , _context :: Context 78 | , _substitution :: Substitution TermF 79 | , _nextMeta :: MetaVar 80 | , _aliases :: Aliases 81 | , _moduleName :: String 82 | , _moduleNames :: [String] 83 | } 84 | L.makeLenses ''ElabState 85 | 86 | 87 | type Elaborator = StateT ElabState (Either String) 88 | 89 | 90 | type TypeChecker = Elaborator 91 | 92 | 93 | runElaborator :: Elaborator a 94 | -> Signature 95 | -> Definitions 96 | -> Context 97 | -> Aliases 98 | -> String 99 | -> [String] 100 | -> Either String (a,ElabState) 101 | runElaborator e sig defs ctx als modname mods = 102 | runStateT e (ElabState sig defs ctx [] (MetaVar 0) als modname mods) 103 | 104 | 105 | runElaborator0 :: Elaborator a -> Either String (a,ElabState) 106 | runElaborator0 e = runElaborator e [] [] [] [] "" [] 107 | 108 | 109 | when' :: Elaborator a -> Elaborator () -> Elaborator () 110 | when' e1 e2 = do s <- get 111 | case runStateT e1 s of 112 | Left _ -> return () 113 | Right _ -> e2 -------------------------------------------------------------------------------- /src/Modular/Unification/REPL.hs: -------------------------------------------------------------------------------- 1 | module Modular.Unification.REPL where 2 | 3 | import Control.Monad.Reader (runReaderT) 4 | import System.IO 5 | 6 | import Utils.ABT 7 | import Utils.Env 8 | import Utils.Eval 9 | import Utils.Names 10 | import Utils.Pretty 11 | import Modular.Core.ConSig 12 | import Modular.Core.Evaluation 13 | import Modular.Core.Parser 14 | import Modular.Core.Term 15 | import Modular.Unification.Elaborator 16 | import Modular.Unification.Elaboration 17 | import Modular.Unification.TypeChecking 18 | 19 | 20 | 21 | flushStr :: String -> IO () 22 | flushStr str = putStr str >> hFlush stdout 23 | 24 | readPrompt :: String -> IO String 25 | readPrompt prompt = flushStr prompt >> getLine 26 | 27 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 28 | until_ p prompt action = do 29 | result <- prompt 30 | if p result 31 | then return () 32 | else action result >> until_ p prompt action 33 | 34 | repl :: String -> IO () 35 | repl src = case loadProgram src of 36 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 37 | Right (sig,defs,ctx,env) 38 | -> do hSetBuffering stdin LineBuffering 39 | until_ (== ":quit") 40 | (readPrompt "$> ") 41 | (evalAndPrint sig defs ctx env) 42 | where 43 | loadProgram :: String 44 | -> Either String ( Signature 45 | , Definitions 46 | , Context 47 | , Env (String,String) Term 48 | ) 49 | loadProgram src 50 | = do prog <- parseProgram src 51 | (_,ElabState sig defs ctx _ _ _ _ _) <- 52 | runElaborator0 (elabProgram prog) 53 | let env = definitionsToEnvironment defs 54 | return (sig,defs,ctx,env) 55 | 56 | loadTerm :: Signature 57 | -> Definitions 58 | -> Context 59 | -> Env (String,String) Term 60 | -> String 61 | -> Either String Term 62 | loadTerm sig defs ctx env src 63 | = do tm0 <- parseTerm src 64 | let tm = freeToDefined (In . Defined . BareLocal) tm0 65 | als = [ (Right p,p) | (p,_) <- sig ] 66 | ++ [ (Right p,p) | (p,_) <- defs ] 67 | case runElaborator (infer tm) sig defs ctx als "" [] of 68 | Left e -> Left e 69 | Right ((etm,_),_) -> runReaderT (eval etm) env 70 | 71 | evalAndPrint :: Signature 72 | -> Definitions 73 | -> Context 74 | -> Env (String,String) Term 75 | -> String 76 | -> IO () 77 | evalAndPrint _ _ _ _ "" = return () 78 | evalAndPrint sig defs ctx env src 79 | = case loadTerm sig defs ctx env src of 80 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 81 | Right v -> flushStr (pretty v ++ "\n") 82 | 83 | replFile :: String -> IO () 84 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Modular/Unification/Unification.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -- | This module defines unification of dependent types. 15 | 16 | module Modular.Unification.Unification where 17 | 18 | import Utils.ABT 19 | import Utils.Elaborator 20 | import Utils.Names 21 | import Utils.Pretty 22 | import Utils.Telescope 23 | import Utils.Unifier 24 | import Modular.Core.Term 25 | import Modular.Unification.Elaborator 26 | 27 | import Control.Monad.Except 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | -- | Equating terms by trivial structural equations. 36 | 37 | instance MonadUnify TermF Elaborator where 38 | equate (Defined n1) (Defined n2) = 39 | if n1 == n2 40 | then return [] 41 | else throwError $ "Mismatching names " 42 | ++ showName n1 ++ " and " ++ showName n2 43 | equate (Ann m1 t1) (Ann m2 t2) = 44 | return [ Equation (instantiate0 m1) (instantiate0 m2) 45 | , Equation (instantiate0 t1) (instantiate0 t2) 46 | ] 47 | equate Type Type = 48 | return [] 49 | equate (Fun plic1 a1 sc1) (Fun plic2 a2 sc2) = 50 | do unless (plic1 == plic2) 51 | $ throwError $ "Mismatching plicities when unifying " 52 | ++ pretty (In (Fun plic1 a1 sc1)) ++ " with " 53 | ++ pretty (In (Fun plic2 a2 sc2)) 54 | ns <- freshRelTo (names sc1) context 55 | let xs = map (Var . Free) ns 56 | return [ Equation (instantiate0 a1) (instantiate0 a2) 57 | , Equation (instantiate sc1 xs) (instantiate sc2 xs) 58 | ] 59 | equate (Lam plic1 sc1) (Lam plic2 sc2) = 60 | do unless (plic1 == plic2) 61 | $ throwError $ "Mismatching plicities when unifying " 62 | ++ pretty (In (Lam plic1 sc1)) ++ " with " 63 | ++ pretty (In (Lam plic2 sc2)) 64 | ns <- freshRelTo (names sc1) context 65 | let xs = map (Var . Free) ns 66 | return [ Equation (instantiate sc1 xs) (instantiate sc2 xs) ] 67 | equate (App plic1 f1 a1) (App plic2 f2 a2) = 68 | do unless (plic1 == plic2) 69 | $ throwError $ "Mismatching plicities when unifying " 70 | ++ pretty (In (App plic1 f1 a1)) ++ " with " 71 | ++ pretty (In (App plic2 f2 a2)) 72 | return [ Equation (instantiate0 f1) (instantiate0 f2) 73 | , Equation (instantiate0 a1) (instantiate0 a2) 74 | ] 75 | equate (Con c1 as1) (Con c2 as2) = 76 | do unless (c1 == c2) 77 | $ throwError $ "Mismatching constructors " 78 | ++ showName c1 ++ " and " ++ showName c2 79 | unless (length as1 == length as2) 80 | $ throwError $ "Mismatching constructor arg lengths between " 81 | ++ pretty (In (Con c1 as1)) ++ " and " 82 | ++ pretty (In (Con c2 as1)) 83 | let (plics1,as1') = unzip as1 84 | (plics2,as2') = unzip as2 85 | unless (plics1 == plics2) 86 | $ throwError $ "Mismatching plicities when unifying " 87 | ++ pretty (In (Con c1 as1)) ++ " with " 88 | ++ pretty (In (Con c2 as2)) 89 | return $ zipWith 90 | Equation 91 | (map instantiate0 as1') 92 | (map instantiate0 as2') 93 | equate (Case as1 mot1 cs1) (Case as2 mot2 cs2) = 94 | do unless (length as1 == length as2) 95 | $ throwError $ "Mismatching number of case arguments in " 96 | ++ pretty (In (Case as1 mot1 cs1)) ++ " and " 97 | ++ pretty (In (Case as2 mot2 cs2)) 98 | unless (length cs1 == length cs2) 99 | $ throwError $ "Mismatching number of clauses in " 100 | ++ pretty (In (Case as1 mot1 cs1)) ++ " and " 101 | ++ pretty (In (Case as2 mot2 cs2)) 102 | let argEqs = zipWith 103 | Equation 104 | (map instantiate0 as1) 105 | (map instantiate0 as2) 106 | motEqs <- equateCaseMotive mot1 mot2 107 | clauseEqs <- fmap concat $ zipWithM equateClause cs1 cs2 108 | return $ argEqs ++ motEqs ++ clauseEqs 109 | equate l r = 110 | throwError $ "Cannot unify " ++ pretty (In l) ++ " with " ++ pretty (In r) 111 | 112 | 113 | 114 | 115 | 116 | -- | Equating case motives as a special helper for the main 'equate' method. 117 | 118 | equateCaseMotive :: CaseMotive -> CaseMotive -> Elaborator [Equation Term] 119 | equateCaseMotive mot1@(CaseMotive tele1) mot2@(CaseMotive tele2) = 120 | do ns <- freshRelTo (namesBindingTelescope tele1) context 121 | let xs = map (Var . Free) ns 122 | (as1, b1) = instantiateBindingTelescope tele1 xs 123 | (as2, b2) = instantiateBindingTelescope tele2 xs 124 | unless (length as1 == length as2) 125 | $ throwError $ "Motives not equal: " ++ pretty mot1 ++ " and " 126 | ++ pretty mot2 127 | return $ zipWith Equation as1 as2 ++ [ Equation b1 b2 ] 128 | 129 | 130 | 131 | 132 | 133 | -- Equating clauses as a special helper for the main 'equate' method. 134 | 135 | equateClause :: Clause -> Clause -> Elaborator [Equation Term] 136 | equateClause (Clause pscs1 sc1) (Clause pscs2 sc2) = 137 | do unless (length pscs1 == length pscs2) 138 | $ throwError "Clauses have different numbers of patterns." 139 | unless (length (names sc1) == length (names sc2)) 140 | $ throwError "Patterns bind different numbers of arguments." 141 | ns <- freshRelTo (names sc1) context 142 | let xs = map (Var . Free) ns 143 | xs' = map (Var . Free) ns 144 | ps1 = map (\sc -> patternInstantiate sc xs xs') pscs1 145 | ps2 = map (\sc -> patternInstantiate sc xs xs') pscs2 146 | b1 = instantiate sc1 xs' 147 | b2 = instantiate sc2 xs' 148 | case sequence (zipWith zipABTF ps1 ps2) of 149 | Nothing -> 150 | throwError "Patterns are not equal." 151 | Just pEqss -> 152 | return $ [ Equation a1 a2 | (a1,a2) <- concat pEqss ] 153 | ++ [ Equation b1 b2 ] -------------------------------------------------------------------------------- /src/OpenDefs/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | module OpenDefs.Core.ConSig where 10 | 11 | import Utils.ABT 12 | import Utils.Names 13 | import Utils.Plicity 14 | import Utils.Pretty (pretty) 15 | import Utils.Telescope 16 | import OpenDefs.Core.DeclArg 17 | import OpenDefs.Core.Term 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | data ConSig = ConSig [Plicity] (BindingTelescope (Scope TermF)) 26 | 27 | 28 | instance Show ConSig where 29 | show (ConSig plics (BindingTelescope ascs bsc)) = 30 | binders ++ " " ++ pretty (body bsc) 31 | where 32 | binders = 33 | unwords 34 | (zipWith 35 | (\n (plic,a) -> wrap plic (n ++ " : " ++ a)) 36 | ns 37 | (zip plics as)) 38 | as = map (pretty.body) ascs 39 | ns = names bsc 40 | 41 | wrap Expl x = "(" ++ x ++ ")" 42 | wrap Impl x = "{" ++ x ++ "}" 43 | 44 | 45 | conSigH :: [DeclArg] -> Term -> ConSig 46 | conSigH declas b = ConSig plics (bindingTelescopeH xs as b) 47 | where (plics,xas) = unzip [ (plic,(x,a)) | DeclArg plic x a <- declas ] 48 | (xs,as) = unzip xas 49 | 50 | 51 | freeToDefinedConSig :: ConSig -> ConSig 52 | freeToDefinedConSig (ConSig plics tele) = 53 | ConSig plics (fmap (freeToDefinedScope (In . Defined . BareLocal)) tele) -------------------------------------------------------------------------------- /src/OpenDefs/Core/DeclArg.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | module OpenDefs.Core.DeclArg where 6 | 7 | import Utils.Plicity 8 | import Utils.Pretty 9 | import OpenDefs.Core.Term 10 | 11 | 12 | 13 | data DeclArg = DeclArg Plicity String Term 14 | 15 | instance Show DeclArg where 16 | show (DeclArg Expl x t) = "(" ++ x ++ " : " ++ pretty t ++ ")" 17 | show (DeclArg Impl x t) = "{" ++ x ++ " : " ++ pretty t ++ "}" -------------------------------------------------------------------------------- /src/OpenDefs/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module defines what it means to be a program in the dependently 10 | -- typed lambda calculus. 11 | 12 | module OpenDefs.Core.Program where 13 | 14 | import Utils.Names 15 | import Utils.Plicity 16 | import Utils.Pretty 17 | import OpenDefs.Core.ConSig 18 | import OpenDefs.Core.DeclArg 19 | import OpenDefs.Core.Term 20 | 21 | import Data.List (intercalate) 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | -- | A 'Statement' is either a 'TypeDeclaration' or a 'TermDeclaration'. 30 | 31 | data Statement 32 | = TyDecl TypeDeclaration 33 | | TmDecl TermDeclaration 34 | 35 | instance Show Statement where 36 | show (TyDecl td) = show td 37 | show (TmDecl td) = show td 38 | 39 | 40 | 41 | 42 | 43 | -- | A term can be declared either with a simple equality, as in 44 | -- 45 | -- > let not : Bool -> Bool 46 | -- > = \b -> case b of 47 | -- > | True -> False 48 | -- > | False -> True 49 | -- > end 50 | -- > end 51 | -- 52 | -- or with a pattern match, as in 53 | -- 54 | -- > let not : Bool -> Bool where 55 | -- > | not True = False 56 | -- > | not False = True 57 | -- > end 58 | 59 | data TermDeclaration 60 | = TermDeclaration String Term Term 61 | | WhereDeclaration String Term [([Plicity],([String],[Pattern],Term))] 62 | | LetFamilyDeclaration String [DeclArg] Term 63 | | LetInstanceDeclaration Name [([Plicity],([String],[Pattern],Term))] 64 | 65 | instance Show TermDeclaration where 66 | show (TermDeclaration n ty def) = 67 | "let " ++ n ++ " : " ++ pretty ty ++ " = " ++ pretty def ++ " end" 68 | show (WhereDeclaration n ty preclauses) 69 | = "let " ++ n ++ " : " ++ pretty ty ++ " where " 70 | ++ intercalate " | " (map showPreclause preclauses) 71 | where 72 | show (LetFamilyDeclaration n args ty) = 73 | "let family " ++ n ++ " " ++ unwords (map show args) 74 | ++ " : " ++ pretty ty ++ " end" 75 | show (LetInstanceDeclaration n preclauses) = 76 | "let instance " ++ show n ++ " where " 77 | ++ intercalate " | " (map showPreclause preclauses) 78 | 79 | 80 | 81 | 82 | 83 | -- | Since two different kinds of declarations can be defined via pattern 84 | -- matching now, we extract out the utility function 'showPreclause' for that. 85 | 86 | showPreclause :: ([Plicity],([String],[Pattern],Term)) -> String 87 | showPreclause (plics,(_,ps,b)) 88 | = intercalate 89 | " || " 90 | (map showPattern (zip plics ps)) 91 | ++ " -> " ++ pretty b 92 | 93 | 94 | 95 | 96 | 97 | -- | Similarly we extract out 'showPattern'. 98 | 99 | showPattern :: (Plicity,Pattern) -> String 100 | showPattern (Expl,p) = parenthesize (Just (ConPatArg Expl)) p 101 | showPattern (Impl,p) = parenthesize (Just (ConPatArg Impl)) p 102 | 103 | 104 | 105 | 106 | 107 | -- | A type is declared with a GADT-like notation, however instead of giving 108 | -- the type of a constructor, as in Haskell or Agda, a constructor's signature 109 | -- is given via exemplified application, as in: 110 | -- 111 | -- @ 112 | -- data List (a : Type) where 113 | -- | Nil : List a 114 | -- | Cons (x : a) (xs : List a) : List a 115 | -- end 116 | -- @ 117 | -- 118 | -- Types with no constructors need no @where@: 119 | -- 120 | -- > data Void end 121 | 122 | data TypeDeclaration 123 | = TypeDeclaration String [DeclArg] [(String,ConSig)] 124 | | DataFamilyDeclaration String [DeclArg] 125 | | DataInstanceDeclaration Name [(String,ConSig)] 126 | 127 | instance Show TypeDeclaration where 128 | show (TypeDeclaration tycon tyargs []) = 129 | "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 130 | show (TypeDeclaration tycon tyargs alts) = 131 | "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " where" 132 | ++ concat [ "\n" ++ c ++ " : " ++ show sig | (c,sig) <- alts ] 133 | ++ "\nend" 134 | show (DataFamilyDeclaration tycon tyargs) = 135 | "data family " ++ tycon 136 | ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 137 | show (DataInstanceDeclaration tycon alts) = 138 | "data instance " ++ show tycon ++ " where" 139 | ++ concat [ "\n" ++ c ++ " : " ++ show sig 140 | | (c,sig) <- alts 141 | ] 142 | ++ "\nend" 143 | 144 | 145 | 146 | 147 | 148 | -- | Settings for hiding or using names from a module. 149 | 150 | data HidingUsing 151 | = Hiding [String] 152 | | Using [String] 153 | 154 | 155 | 156 | 157 | 158 | -- | Settings for opening a module's names for use. 159 | 160 | data OpenSettings 161 | = OpenSettings 162 | { openModule :: String 163 | , openAs :: Maybe String 164 | , openHidingUsing :: Maybe HidingUsing 165 | , openRenaming :: [(String,String)] 166 | } 167 | 168 | instance Show OpenSettings where 169 | show (OpenSettings m a hu r) 170 | = m ++ a' ++ hu' ++ r' 171 | where 172 | a' = case a of 173 | Nothing -> "" 174 | Just m' -> " as " ++ m' 175 | hu' = case hu of 176 | Nothing -> "" 177 | Just (Hiding ns) -> " hiding (" ++ intercalate "," ns ++ ")" 178 | Just (Using ns) -> " using (" ++ intercalate "," ns ++ ")" 179 | r' = case r of 180 | [] -> "" 181 | _ -> " renaming (" 182 | ++ intercalate 183 | ", " 184 | [ n ++ " to " ++ n' 185 | | (n,n') <- r 186 | ] 187 | ++ ")" 188 | 189 | 190 | 191 | 192 | 193 | -- | Modules with imports of other modules. 194 | 195 | data Module 196 | = Module String [OpenSettings] [Statement] 197 | 198 | instance Show Module where 199 | show (Module n [] stmts) 200 | = "module " ++ n ++ " where\n\n" 201 | ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 202 | show (Module n settings stmts) 203 | = "module " ++ n ++ " opening " ++ intercalate " | " (map show settings) 204 | ++ " where\n\n" ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 205 | 206 | 207 | 208 | 209 | 210 | -- | A program is just a series of 'Module's. 211 | 212 | newtype Program = Program [Module] 213 | 214 | instance Show Program where 215 | show (Program stmts) = intercalate "\n\n" (map show stmts) -------------------------------------------------------------------------------- /src/OpenDefs/Demo.sfp: -------------------------------------------------------------------------------- 1 | module Demo where 2 | 3 | data family Bool end 4 | 5 | data instance Bool where 6 | | True : Bool 7 | end 8 | 9 | let family id (b : Bool) : Bool end 10 | 11 | let instance id where 12 | | id True = True 13 | end 14 | 15 | end 16 | 17 | module Demo2 opening Demo where 18 | 19 | data instance Bool where 20 | | False : Bool 21 | end 22 | 23 | let instance id where 24 | | id False = False 25 | end 26 | 27 | end -------------------------------------------------------------------------------- /src/OpenDefs/Unification/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -- This module defines the core types of a monadic elaborator. 12 | 13 | module OpenDefs.Unification.Elaborator where 14 | 15 | import Utils.Env 16 | import Utils.Plicity 17 | import Utils.Unifier 18 | import Utils.Vars 19 | import OpenDefs.Core.ConSig 20 | import OpenDefs.Core.Term 21 | 22 | import qualified Control.Lens as L 23 | import Control.Monad.State 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | -- | A signature is a collection of constructors together with their 32 | -- constructor signatures. This is used during type checking and elaboration 33 | -- to define the underlying type theory. 34 | 35 | type Signature = [((String,String),ConSig)] 36 | 37 | 38 | 39 | 40 | 41 | -- | A definition consists of a declared name together with its definition 42 | -- and its type. 43 | 44 | type Definitions = [((String,String),(Term,Term))] 45 | 46 | definitionsToEnvironment :: Definitions -> Env (String,String) Term 47 | definitionsToEnvironment defs = 48 | [ (x,m) | (x,(m,_)) <- defs ] 49 | 50 | 51 | 52 | 53 | 54 | -- | A context contains generated variables together with their display names, 55 | -- and their declared types. 56 | 57 | type Context = [(FreeVar,Term)] 58 | 59 | 60 | 61 | 62 | 63 | -- | Aliases are just maps from local names to absolute names. 64 | 65 | type Aliases = [(Either String (String,String), (String,String))] 66 | 67 | 68 | 69 | 70 | 71 | -- | Open functions have to story their pattern matching definitions so they 72 | -- can be re-built when new instances are added. 73 | 74 | type OpenFunction = ((String,String),(Term,[Plicity],CaseMotive,[Clause])) 75 | 76 | 77 | 78 | 79 | 80 | -- | The definition of the state to be carried by the type checking monad for 81 | -- this particular variant. 82 | 83 | data ElabState 84 | = ElabState 85 | { _signature :: Signature 86 | , _definitions :: Definitions 87 | , _context :: Context 88 | , _substitution :: Substitution TermF 89 | , _nextMeta :: MetaVar 90 | , _aliases :: Aliases 91 | , _moduleName :: String 92 | , _moduleNames :: [String] 93 | , _openData :: [(String,String)] 94 | , _openFunctions :: [OpenFunction] 95 | } 96 | L.makeLenses ''ElabState 97 | 98 | 99 | type Elaborator = StateT ElabState (Either String) 100 | 101 | 102 | type TypeChecker = Elaborator 103 | 104 | 105 | runElaborator :: Elaborator a 106 | -> Signature 107 | -> Definitions 108 | -> Context 109 | -> Aliases 110 | -> String 111 | -> [String] 112 | -> [(String,String)] 113 | -> [OpenFunction] 114 | -> Either String (a,ElabState) 115 | runElaborator e sig defs ctx als modname mods odata ofuns = 116 | runStateT 117 | e 118 | (ElabState sig defs ctx [] (MetaVar 0) als modname mods odata ofuns) 119 | 120 | 121 | runElaborator0 :: Elaborator a -> Either String (a,ElabState) 122 | runElaborator0 e = runElaborator e [] [] [] [] "" [] [] [] 123 | 124 | 125 | when' :: Elaborator a -> Elaborator () -> Elaborator () 126 | when' e1 e2 = do s <- get 127 | case runStateT e1 s of 128 | Left _ -> return () 129 | Right _ -> e2 -------------------------------------------------------------------------------- /src/OpenDefs/Unification/REPL.hs: -------------------------------------------------------------------------------- 1 | module OpenDefs.Unification.REPL where 2 | 3 | import Control.Monad.Reader (runReaderT) 4 | import System.IO 5 | 6 | import Utils.ABT 7 | import Utils.Env 8 | import Utils.Eval 9 | import Utils.Names 10 | import Utils.Pretty 11 | import OpenDefs.Core.ConSig 12 | import OpenDefs.Core.Evaluation 13 | import OpenDefs.Core.Parser 14 | import OpenDefs.Core.Term 15 | import OpenDefs.Unification.Elaborator 16 | import OpenDefs.Unification.Elaboration 17 | import OpenDefs.Unification.TypeChecking 18 | 19 | 20 | 21 | flushStr :: String -> IO () 22 | flushStr str = putStr str >> hFlush stdout 23 | 24 | readPrompt :: String -> IO String 25 | readPrompt prompt = flushStr prompt >> getLine 26 | 27 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 28 | until_ p prompt action = do 29 | result <- prompt 30 | if p result 31 | then return () 32 | else action result >> until_ p prompt action 33 | 34 | repl :: String -> IO () 35 | repl src = case loadProgram src of 36 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 37 | Right (sig,defs,ctx,env) 38 | -> do hSetBuffering stdin LineBuffering 39 | until_ (== ":quit") 40 | (readPrompt "$> ") 41 | (evalAndPrint sig defs ctx env) 42 | where 43 | loadProgram :: String 44 | -> Either String ( Signature 45 | , Definitions 46 | , Context 47 | , Env (String,String) Term 48 | ) 49 | loadProgram src 50 | = do prog <- parseProgram src 51 | (_,ElabState sig defs ctx _ _ _ _ _ _ _) <- 52 | runElaborator0 (elabProgram prog) 53 | let env = definitionsToEnvironment defs 54 | return (sig,defs,ctx,env) 55 | 56 | loadTerm :: Signature 57 | -> Definitions 58 | -> Context 59 | -> Env (String,String) Term 60 | -> String 61 | -> Either String Term 62 | loadTerm sig defs ctx env src 63 | = do tm0 <- parseTerm src 64 | let tm = freeToDefined (In . Defined . BareLocal) tm0 65 | als = [ (Right p,p) | (p,_) <- sig ] 66 | ++ [ (Right p,p) | (p,_) <- defs ] 67 | case runElaborator (infer tm) sig defs ctx als "" [] [] [] of 68 | Left e -> Left e 69 | Right ((etm,_),_) -> runReaderT (eval etm) env 70 | 71 | evalAndPrint :: Signature 72 | -> Definitions 73 | -> Context 74 | -> Env (String,String) Term 75 | -> String 76 | -> IO () 77 | evalAndPrint _ _ _ _ "" = return () 78 | evalAndPrint sig defs ctx env src 79 | = case loadTerm sig defs ctx env src of 80 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 81 | Right v -> flushStr (pretty v ++ "\n") 82 | 83 | replFile :: String -> IO () 84 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Poly/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module implements constructor signatures, for data declarations. 10 | 11 | module Poly.Core.ConSig where 12 | 13 | import Utils.ABT 14 | import Utils.Pretty (pretty) 15 | import Poly.Core.Type 16 | 17 | import Data.List (intercalate) 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | -- | A constructor signature in this variant is simply a list of argument 26 | -- types and a return type. 27 | 28 | data ConSig = ConSig [Scope TypeF] (Scope TypeF) 29 | 30 | 31 | instance Show ConSig where 32 | show (ConSig as r) = 33 | "(" ++ intercalate "," (map (pretty.body) as) ++ ")" ++ pretty (body r) 34 | 35 | 36 | conSigH :: [String] -> [Type] -> Type -> ConSig 37 | conSigH ns as r = ConSig (map (scope ns) as) (scope ns r) -------------------------------------------------------------------------------- /src/Poly/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | 7 | 8 | 9 | 10 | -- | This module defines how to evaluate terms in the simply typed lambda 11 | -- calculus w/ non-parametric user defined types (eg Bool, Nat). 12 | 13 | module Poly.Core.Evaluation where 14 | 15 | import Utils.ABT 16 | import Utils.Env 17 | import Utils.Eval 18 | import Utils.Pretty (pretty) 19 | import Poly.Core.Term 20 | 21 | import Control.Monad.Except 22 | 23 | 24 | 25 | 26 | 27 | -- | Pattern matching for case expressions. 28 | 29 | matchPattern :: Pattern -> Term -> Maybe [Term] 30 | matchPattern (Var _) v = Just [v] 31 | matchPattern (In (ConPat c ps)) (In (Con c' as)) 32 | | c == c' && length ps == length as = 33 | fmap concat (zipWithM matchPattern (map body ps) (map body as)) 34 | matchPattern _ _ = Nothing 35 | 36 | matchPatterns :: [Pattern] -> [Term] -> Maybe [Term] 37 | matchPatterns ps zs = fmap concat (zipWithM matchPattern ps zs) 38 | 39 | matchClauses :: [Clause] -> [Term] -> Maybe Term 40 | matchClauses [] _ = 41 | Nothing 42 | matchClauses (Clause pscs sc:cs) vs = 43 | case matchPatterns (map body pscs) vs of 44 | Nothing -> matchClauses cs vs 45 | Just xs -> Just (instantiate sc xs) 46 | 47 | 48 | 49 | 50 | 51 | -- | Standard eager evaluation. 52 | 53 | instance Eval (Env String Term) Term where 54 | eval (Var v) = 55 | return $ Var v 56 | eval (In (Defined x)) = 57 | do env <- environment 58 | case lookup x env of 59 | Nothing -> throwError $ "Unknown constant/defined term: " ++ x 60 | Just m -> return m 61 | eval (In (Ann m _)) = 62 | eval (instantiate0 m) 63 | eval (In (Lam sc)) = 64 | return $ In (Lam sc) 65 | eval (In (App f a)) = 66 | do ef <- eval (instantiate0 f) 67 | ea <- eval (instantiate0 a) 68 | case ef of 69 | In (Lam sc) -> eval (instantiate sc [ea]) 70 | _ -> return $ appH ef ea 71 | eval (In (Con c as)) = 72 | do eas <- mapM (eval . instantiate0) as 73 | return $ conH c eas 74 | eval (In (Case ms cs)) = 75 | do ems <- mapM (eval . instantiate0) ms 76 | case matchClauses cs ems of 77 | Nothing -> throwError $ "Incomplete pattern match: " ++ pretty (In (Case ms cs)) 78 | Just b -> eval b -------------------------------------------------------------------------------- /src/Poly/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | -- | This module defines what it means to be a program in the simply typed 8 | -- lambda calculus w/ parametric user defined types (eg Maybe, List). 9 | 10 | module Poly.Core.Program where 11 | 12 | import Utils.ABT 13 | import Utils.Pretty 14 | import Poly.Core.ConSig 15 | import Poly.Core.Term 16 | import Poly.Core.Type 17 | 18 | import Data.List (intercalate) 19 | 20 | 21 | 22 | 23 | 24 | -- | A program is just a series of 'Statement's. 25 | 26 | newtype Program = Program [Statement] 27 | 28 | instance Show Program where 29 | show (Program stmts) = intercalate "\n\n" (map show stmts) 30 | 31 | 32 | 33 | 34 | 35 | -- | A 'Statement' is either a 'TypeDeclaration' or a 'TermDeclaration'. 36 | 37 | data Statement 38 | = TyDecl TypeDeclaration 39 | | TmDecl TermDeclaration 40 | 41 | instance Show Statement where 42 | show (TyDecl td) = show td 43 | show (TmDecl td) = show td 44 | 45 | 46 | 47 | 48 | 49 | -- | A term can be declared either with a simple equality, as in 50 | -- 51 | -- > let not : Bool -> Bool 52 | -- > = \b -> case b of 53 | -- > | True -> False 54 | -- > | False -> True 55 | -- > end 56 | -- > end 57 | -- 58 | -- or with a pattern match, as in 59 | -- 60 | -- > let not : Bool -> Bool where 61 | -- > | not True = False 62 | -- > | not False = True 63 | -- > end 64 | 65 | data TermDeclaration 66 | = TermDeclaration String Type Term 67 | | WhereDeclaration String Type [([Pattern],[String],Term)] 68 | 69 | instance Show TermDeclaration where 70 | show (TermDeclaration n ty def) = 71 | "let " ++ n ++ " : " ++ pretty ty ++ " = " ++ pretty def ++ " end" 72 | show (WhereDeclaration n ty preclauses) = 73 | "let " ++ n ++ " : " ++ pretty ty ++ " where " 74 | ++ intercalate " | " (map showPreclause preclauses) 75 | where 76 | showPreclause :: ([Pattern],[String],Term) -> String 77 | showPreclause (ps,_,b) = 78 | intercalate " || " (map pretty ps) ++ " -> " ++ pretty b 79 | 80 | 81 | 82 | 83 | 84 | -- | A type is declared with Haskell-like notation, as in 85 | -- 86 | -- > data Bool = True | False end 87 | -- 88 | -- Types with no constructors need no @=@: 89 | -- 90 | -- > data Void end 91 | 92 | data TypeDeclaration 93 | = TypeDeclaration String [String] [(String,ConSig)] 94 | 95 | instance Show TypeDeclaration where 96 | show (TypeDeclaration tycon params []) = 97 | "data " ++ tycon ++ concat (map (' ':) params) ++ " end" 98 | show (TypeDeclaration tycon params alts) = 99 | "data " ++ tycon ++ concat (map (' ':) params) ++ " = " 100 | ++ intercalate 101 | " | " 102 | [ showAlt c (map body as) | (c, ConSig as _) <- alts ] 103 | ++ " end" 104 | where 105 | showAlt :: String -> [Type] -> String 106 | showAlt c [] = c 107 | showAlt c as = c ++ " " ++ unwords (map pretty as) -------------------------------------------------------------------------------- /src/Poly/Core/Term.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | 10 | 11 | 12 | 13 | 14 | -- | The terms of the simply typed lambda calculus w/ non-parametric user 15 | -- defined types (eg Bool, Nat). 16 | 17 | module Poly.Core.Term where 18 | 19 | import Poly.Core.Type 20 | 21 | import Utils.ABT 22 | import Utils.Pretty 23 | 24 | import Data.List (intercalate) 25 | 26 | 27 | 28 | 29 | 30 | -- | There are five kinds of terms, an annotated term @M : T@, a lambda term 31 | -- @\\x -> M@, an application term @M N@, a constructor term @C M0 ... Mn@, and 32 | -- a case term @case M0 || ... || Mn of p0* -> N0 | ... | pm* -> Nm end@. 33 | 34 | data TermF r 35 | = Defined String 36 | | Ann r Type 37 | | Lam r 38 | | App r r 39 | | Con String [r] 40 | | Case [r] [ClauseF r] 41 | deriving (Functor,Foldable) 42 | 43 | 44 | type Term = ABT TermF 45 | 46 | 47 | -- | Clauses are a subsort of terms that has bunch of pattern scopes together 48 | -- with a clause body. 49 | 50 | data ClauseF r = Clause [Scope PatternF] r 51 | deriving (Functor,Foldable) 52 | 53 | 54 | type Clause = ClauseF (Scope TermF) 55 | 56 | 57 | -- | Patterns are only constructor patterns, with some number of pattern args. 58 | 59 | data PatternF r = ConPat String [r] 60 | deriving (Functor,Foldable,Traversable) 61 | 62 | 63 | type Pattern = ABT PatternF 64 | 65 | 66 | defined :: String -> Term 67 | defined n = In (Defined n) 68 | 69 | annH :: Term -> Type -> Term 70 | annH m t = In (Ann (scope [] m) t) 71 | 72 | lamH :: String -> Term -> Term 73 | lamH v b = In (Lam (scope [v] b)) 74 | 75 | appH :: Term -> Term -> Term 76 | appH f x = In (App (scope [] f) (scope [] x)) 77 | 78 | conH :: String -> [Term] -> Term 79 | conH c xs = In (Con c (map (scope []) xs)) 80 | 81 | caseH :: [Term] -> [Clause] -> Term 82 | caseH as cs = In (Case (map (scope []) as) cs) 83 | 84 | clauseH :: [String] -> [Pattern] -> Term -> Clause 85 | clauseH vs ps b = Clause (map (scope vs) ps) (scope vs b) 86 | 87 | conPatH :: String -> [Pattern] -> Pattern 88 | conPatH c xs = In (ConPat c (map (scope []) xs)) 89 | 90 | 91 | 92 | 93 | 94 | -- | Terms have a variety of locations that can potentially be sites of 95 | -- de-parenthesization. 96 | 97 | data TermParenLoc 98 | = AnnTerm 99 | | LamBody | AppFun | AppArg 100 | | ConArg | CaseArg | ClauseBody 101 | deriving (Eq) 102 | 103 | 104 | instance Parens Term where 105 | type Loc Term = TermParenLoc 106 | 107 | parenLoc (Var _) = 108 | [AnnTerm,LamBody,AppFun,AppArg,ConArg,CaseArg,ClauseBody] 109 | parenLoc (In (Defined _)) = 110 | [AnnTerm,LamBody,AppFun,AppArg,ConArg,CaseArg,ClauseBody] 111 | parenLoc (In (Ann _ _)) = 112 | [LamBody,CaseArg,ClauseBody] 113 | parenLoc (In (Lam _)) = 114 | [LamBody,CaseArg,ClauseBody] 115 | parenLoc (In (App _ _)) = 116 | [AnnTerm,LamBody,AppFun,CaseArg,ClauseBody] 117 | parenLoc (In (Con _ [])) = 118 | [AnnTerm,LamBody,AppFun,AppArg,ConArg,CaseArg,ClauseBody] 119 | parenLoc (In (Con _ _)) = 120 | [AnnTerm,LamBody,CaseArg,ClauseBody] 121 | parenLoc (In (Case _ _)) = 122 | [LamBody,ClauseBody] 123 | 124 | parenRec (Var v) = 125 | name v 126 | parenRec (In (Defined n)) = n 127 | parenRec (In (Ann m t)) = 128 | parenthesize (Just AnnTerm) (instantiate0 m) 129 | ++ " : " 130 | ++ pretty t 131 | parenRec (In (Lam sc)) = 132 | "\\" ++ unwords (names sc) 133 | ++ " -> " 134 | ++ parenthesize (Just LamBody) 135 | (body sc) 136 | parenRec (In (App f a)) = 137 | parenthesize (Just AppFun) (instantiate0 f) 138 | ++ " " 139 | ++ parenthesize (Just AppArg) (instantiate0 a) 140 | parenRec (In (Con c [])) = 141 | c 142 | parenRec (In (Con c as)) = 143 | c ++ " " 144 | ++ intercalate 145 | " " 146 | (map (parenthesize (Just ConArg) . instantiate0) as) 147 | parenRec (In (Case as cs)) = 148 | "case " 149 | ++ intercalate 150 | " || " 151 | (map (parenthesize (Just CaseArg) . instantiate0) as) 152 | ++ " of " 153 | ++ intercalate " | " (map auxClause cs) ++ " end" 154 | where 155 | auxClause :: Clause -> String 156 | auxClause (Clause pscs sc) = 157 | intercalate " || " 158 | (map (parenthesize Nothing . body) pscs) 159 | ++ " -> " 160 | ++ parenthesize (Just ClauseBody) (body sc) 161 | 162 | 163 | 164 | 165 | 166 | -- | Pattern locations are even simpler, as there's only one: constructor arg. 167 | 168 | data PatternParenLoc = ConPatArg 169 | deriving (Eq) 170 | 171 | instance Parens Pattern where 172 | type Loc Pattern = PatternParenLoc 173 | 174 | parenLoc (Var _) = [ConPatArg] 175 | parenLoc (In (ConPat _ [])) = [ConPatArg] 176 | parenLoc (In (ConPat _ _)) = [] 177 | 178 | parenRec (Var v) = 179 | name v 180 | parenRec (In (ConPat c [])) = c 181 | parenRec (In (ConPat c ps)) = 182 | c ++ " " ++ unwords (map (parenthesize (Just ConPatArg) . body) ps) -------------------------------------------------------------------------------- /src/Poly/Core/Type.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -- | The types of the simply typed lambda calculus w/ non-parametric user 15 | -- defined types (eg Bool, Nat). 16 | 17 | module Poly.Core.Type where 18 | 19 | import Utils.ABT 20 | import Utils.Pretty 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | -- | Types can be type constructors, functions, foralls. 29 | 30 | data TypeF r 31 | = TyCon String [r] 32 | | Fun r r 33 | | Forall r 34 | deriving (Eq,Functor,Foldable) 35 | 36 | 37 | type Type = ABT TypeF 38 | 39 | 40 | 41 | 42 | 43 | tyConH :: String -> [Type] -> Type 44 | tyConH c as = In (TyCon c (map (scope []) as)) 45 | 46 | funH :: Type -> Type -> Type 47 | funH a b = In (Fun (scope [] a) (scope [] b)) 48 | 49 | forallH :: String -> Type -> Type 50 | forallH x b = In (Forall (scope [x] b)) 51 | 52 | 53 | 54 | 55 | 56 | -- | There are two possible recursive locations within a type, so there are 57 | -- two 'TypeParenLoc's for the parenthesizer to use. 58 | 59 | data TypeParenLoc = TyConArg | FunLeft | FunRight | ForallBody 60 | deriving (Eq) 61 | 62 | 63 | -- | Everything can be de-parenthesized everywhere, except for functions. 64 | -- A function can only be de-parenthesized on the right of a function arrow. 65 | 66 | instance Parens Type where 67 | type Loc Type = TypeParenLoc 68 | 69 | parenLoc (Var _) = 70 | [TyConArg,FunLeft,FunRight,ForallBody] 71 | parenLoc (In (TyCon _ [])) = 72 | [TyConArg,FunLeft,FunRight,ForallBody] 73 | parenLoc (In (TyCon _ _)) = 74 | [FunRight,ForallBody] 75 | parenLoc (In (Fun _ _)) = 76 | [FunRight,ForallBody] 77 | parenLoc (In (Forall _)) = 78 | [FunRight,ForallBody] 79 | 80 | parenRec (Var v) = name v 81 | parenRec (In (TyCon c [])) = c 82 | parenRec (In (TyCon c as)) = 83 | c ++ " " 84 | ++ unwords 85 | (map (parenthesize (Just TyConArg) . instantiate0) as) 86 | parenRec (In (Fun a b)) = 87 | parenthesize (Just FunLeft) (instantiate0 a) 88 | ++ " -> " 89 | ++ parenthesize (Just FunRight) (instantiate0 b) 90 | parenRec (In (Forall sc)) = 91 | "forall " ++ unwords (names sc) ++ ". " 92 | ++ parenthesize (Just ForallBody) (body sc) -------------------------------------------------------------------------------- /src/Poly/Demo.sfp: -------------------------------------------------------------------------------- 1 | {- 2 | data Bool = True | False end 3 | 4 | let not : Bool -> Bool 5 | = \b -> case b of 6 | | True -> False 7 | | False -> True 8 | end 9 | end 10 | 11 | data Nat = Zero | Suc Nat end 12 | 13 | let even : Nat -> Bool 14 | = \n -> case n of 15 | | Zero -> True 16 | | Suc Zero -> False 17 | | Suc (Suc n) -> even n 18 | end 19 | end 20 | 21 | let plus : Nat -> Nat -> Nat 22 | = \x -> \y -> 23 | case x of 24 | | Zero -> y 25 | | Suc x2 -> Suc (plus x2 y) 26 | end 27 | end 28 | 29 | let mul : Nat -> Nat -> Nat 30 | = \x -> \y -> 31 | case x of 32 | | Zero -> Zero 33 | | Suc n -> plus y (mul n y) 34 | end 35 | end 36 | -} 37 | 38 | let id : forall a. a -> a 39 | = \x -> x 40 | end 41 | 42 | {- 43 | let const : forall a. forall b. a -> b -> a 44 | = \x -> \y -> x 45 | end 46 | 47 | data Unit = Unit end 48 | 49 | data Delay a = Delay (Unit -> a) end 50 | 51 | let force : forall a. Delay a -> a 52 | = \thunk -> case thunk of 53 | | Delay f -> f Unit 54 | end 55 | end 56 | 57 | let if : forall a. Bool -> Delay a -> Delay a -> a 58 | = \b -> \t -> \f -> 59 | case b of 60 | | True -> force t 61 | | False -> force f 62 | end 63 | end 64 | 65 | data List a = Nil | Cons a (List a) end 66 | 67 | let map : forall a. forall b. (a -> b) -> List a -> List b 68 | = \f -> \l -> 69 | case l of 70 | | Nil -> Nil 71 | | Cons x xs -> Cons (f x) (map f xs) 72 | end 73 | end 74 | 75 | let compose : forall a. forall b. forall c. (b -> c) -> (a -> b) -> a -> c 76 | = \f -> \g -> \x -> f (g x) 77 | end 78 | -} -------------------------------------------------------------------------------- /src/Poly/Unification/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -- This module defines the core types of a unification elaborator. 12 | 13 | module Poly.Unification.Elaborator where 14 | 15 | import Utils.Env 16 | import Utils.Unifier 17 | import Utils.Vars 18 | import Poly.Core.ConSig 19 | import Poly.Core.Term 20 | import Poly.Core.Type 21 | 22 | import qualified Control.Lens as L 23 | import Control.Monad.State 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | -- | A type constructor's signature consists of just the number of parameters 32 | -- the constructor has. 33 | 34 | newtype TyConSig = TyConSig Int 35 | 36 | 37 | 38 | 39 | 40 | -- | A signature is a collection of type constructors, and data constructors 41 | -- together with their constructor signatures. This is used during type 42 | -- checking and elaboration to define the underlying type theory. 43 | 44 | data Signature 45 | = Signature 46 | { _typeConstructors :: [(String,TyConSig)] 47 | , _dataConstructors :: [(String,ConSig)] 48 | } 49 | L.makeLenses ''Signature 50 | 51 | 52 | 53 | 54 | 55 | -- | A definition consists of a declared name together with its definition 56 | -- and its type. 57 | 58 | type Definitions = [(String,(Term,Type))] 59 | 60 | definitionsToEnvironment :: Definitions -> Env String Term 61 | definitionsToEnvironment defs = 62 | [ (x,m) | (x,(m,_)) <- defs ] 63 | 64 | 65 | 66 | 67 | 68 | -- | A context contains generated variables together with their types. 69 | 70 | type Context = [(FreeVar,Type)] 71 | 72 | 73 | 74 | 75 | 76 | -- | A type variable context contains the names of free type variables. 77 | 78 | type TyVarContext = [FreeVar] 79 | 80 | 81 | 82 | 83 | 84 | -- | The definition of the state to be carried by the type checking monad for 85 | -- this particular variant. We need only the bare minimum of a signature, 86 | -- some defined terms, and a typing context. 87 | 88 | data ElabState 89 | = ElabState 90 | { _signature :: Signature 91 | , _definitions :: Definitions 92 | , _context :: Context 93 | , _tyVarContext :: TyVarContext 94 | , _substitution :: Substitution TypeF 95 | , _nextMeta :: MetaVar 96 | } 97 | L.makeLenses ''ElabState 98 | 99 | 100 | type Elaborator = StateT ElabState (Either String) 101 | 102 | 103 | type TypeChecker = Elaborator 104 | 105 | 106 | runElaborator :: Elaborator a 107 | -> Signature 108 | -> Definitions 109 | -> Context 110 | -> Either String (a,ElabState) 111 | runElaborator e sig defs ctx = 112 | runStateT e (ElabState sig defs ctx [] [] (MetaVar 0)) 113 | 114 | 115 | runElaborator0 :: Elaborator a -> Either String (a,ElabState) 116 | runElaborator0 e = runElaborator e (Signature [] []) [] [] 117 | 118 | 119 | when' :: Elaborator a -> Elaborator () -> Elaborator () 120 | when' e1 e2 = do s <- get 121 | case runStateT e1 s of 122 | Left _ -> return () 123 | Right _ -> e2 -------------------------------------------------------------------------------- /src/Poly/Unification/REPL.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | module Poly.Unification.REPL where 7 | 8 | import Control.Monad.Reader (runReaderT) 9 | 10 | import Utils.ABT 11 | import Utils.Env 12 | import Utils.Eval 13 | import Utils.Pretty 14 | import Poly.Core.Evaluation () 15 | import Poly.Core.Parser 16 | import Poly.Core.Term 17 | import Poly.Unification.Elaboration 18 | import Poly.Unification.Elaborator 19 | import Poly.Unification.TypeChecking 20 | 21 | import System.IO 22 | 23 | 24 | 25 | 26 | 27 | flushStr :: String -> IO () 28 | flushStr str = putStr str >> hFlush stdout 29 | 30 | readPrompt :: String -> IO String 31 | readPrompt prompt = flushStr prompt >> getLine 32 | 33 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 34 | until_ p prompt action = do 35 | result <- prompt 36 | if p result 37 | then return () 38 | else action result >> until_ p prompt action 39 | 40 | repl :: String -> IO () 41 | repl src0 = case loadProgram src0 of 42 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 43 | Right (sig,defs,ctx,env) 44 | -> do hSetBuffering stdin LineBuffering 45 | until_ (== ":quit") 46 | (readPrompt "$> ") 47 | (evalAndPrint sig defs ctx env) 48 | where 49 | loadProgram :: String -> Either String (Signature,Definitions,Context,Env String Term) 50 | loadProgram src = 51 | do prog <- parseProgram src 52 | (_,ElabState sig defs ctx _ _ _) <- runElaborator0 (elabProgram prog) 53 | let env = definitionsToEnvironment defs 54 | return (sig,defs,ctx,env) 55 | 56 | loadTerm :: Signature -> Definitions -> Context -> Env String Term -> String -> Either String Term 57 | loadTerm sig defs ctx env src = 58 | do tm0 <- parseTerm src 59 | let tm = freeToDefined (In . Defined) tm0 60 | case runElaborator (infer tm) sig defs ctx of 61 | Left e -> Left e 62 | Right _ -> runReaderT (eval tm) env 63 | 64 | evalAndPrint :: Signature -> Definitions -> Context -> Env String Term -> String -> IO () 65 | evalAndPrint _ _ _ _ "" = return () 66 | evalAndPrint sig defs ctx env src = 67 | case loadTerm sig defs ctx env src of 68 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 69 | Right v -> flushStr (pretty v ++ "\n") 70 | 71 | replFile :: String -> IO () 72 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Poly/Unification/Unification.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -- | This module defines unification of dependent types. 15 | 16 | module Poly.Unification.Unification where 17 | 18 | import Utils.ABT 19 | import Utils.Elaborator 20 | import Utils.Pretty 21 | import Utils.Unifier 22 | import Poly.Core.Type 23 | import Poly.Unification.Elaborator 24 | 25 | import Control.Monad.Except 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | -- | Equating terms by trivial structural equations. 34 | 35 | instance MonadUnify TypeF Elaborator where 36 | equate (TyCon tycon1 as1) (TyCon tycon2 as2) = 37 | do unless (tycon1 == tycon2) 38 | $ throwError $ "Mismatching type constructors " 39 | ++ tycon1 ++ " and " ++ tycon2 40 | unless (length as1 == length as2) 41 | $ throwError $ "Mismatching type constructor arg lengths between " 42 | ++ pretty (In (TyCon tycon1 as1)) ++ " and " 43 | ++ pretty (In (TyCon tycon2 as1)) 44 | return $ zipWith 45 | Equation 46 | (map instantiate0 as1) 47 | (map instantiate0 as2) 48 | equate (Fun a1 b1) (Fun a2 b2) = 49 | return [ Equation (instantiate0 a1) (instantiate0 a2) 50 | , Equation (instantiate0 b1) (instantiate0 b2) 51 | ] 52 | equate (Forall sc1) (Forall sc2) = 53 | do ns <- freshRelTo (names sc1) context 54 | let xs = map (Var . Free) ns 55 | return [ Equation (instantiate sc1 xs) (instantiate sc2 xs) ] 56 | equate l r = 57 | throwError $ "Cannot unify " ++ pretty (In l) ++ " with " ++ pretty (In r) -------------------------------------------------------------------------------- /src/Quasiquote/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | module Quasiquote.Core.ConSig where 10 | 11 | import Utils.ABT 12 | import Utils.Names 13 | import Utils.Plicity 14 | import Utils.Pretty (pretty) 15 | import Utils.Telescope 16 | import Quasiquote.Core.DeclArg 17 | import Quasiquote.Core.Term 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | data ConSig = ConSig [Plicity] (BindingTelescope (Scope TermF)) 26 | 27 | 28 | instance Show ConSig where 29 | show (ConSig plics (BindingTelescope ascs bsc)) = 30 | binders ++ " " ++ pretty (body bsc) 31 | where 32 | binders = 33 | unwords 34 | (zipWith 35 | (\n (plic,a) -> wrap plic (n ++ " : " ++ a)) 36 | ns 37 | (zip plics as)) 38 | as = map (pretty.body) ascs 39 | ns = names bsc 40 | 41 | wrap Expl x = "(" ++ x ++ ")" 42 | wrap Impl x = "{" ++ x ++ "}" 43 | 44 | 45 | conSigH :: [DeclArg] -> Term -> ConSig 46 | conSigH declas b = ConSig plics (bindingTelescopeH xs as b) 47 | where (plics,xas) = unzip [ (plic,(x,a)) | DeclArg plic x a <- declas ] 48 | (xs,as) = unzip xas 49 | 50 | 51 | freeToDefinedConSig :: ConSig -> ConSig 52 | freeToDefinedConSig (ConSig plics tele) = 53 | ConSig plics (fmap (freeToDefinedScope (In . Defined . BareLocal)) tele) -------------------------------------------------------------------------------- /src/Quasiquote/Core/DeclArg.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | module Quasiquote.Core.DeclArg where 6 | 7 | import Utils.Plicity 8 | import Utils.Pretty 9 | import Quasiquote.Core.Term 10 | 11 | 12 | 13 | data DeclArg = DeclArg Plicity String Term 14 | 15 | instance Show DeclArg where 16 | show (DeclArg Expl x t) = "(" ++ x ++ " : " ++ pretty t ++ ")" 17 | show (DeclArg Impl x t) = "{" ++ x ++ " : " ++ pretty t ++ "}" -------------------------------------------------------------------------------- /src/Quasiquote/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module defines what it means to be a program in the dependently 10 | -- typed lambda calculus. 11 | 12 | module Quasiquote.Core.Program where 13 | 14 | import Utils.Names 15 | import Utils.Plicity 16 | import Utils.Pretty 17 | import Quasiquote.Core.ConSig 18 | import Quasiquote.Core.DeclArg 19 | import Quasiquote.Core.Term 20 | 21 | import Data.List (intercalate) 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | -- | A 'Statement' is either a 'TypeDeclaration' or a 'TermDeclaration'. 30 | 31 | data Statement 32 | = TyDecl TypeDeclaration 33 | | TmDecl TermDeclaration 34 | 35 | instance Show Statement where 36 | show (TyDecl td) = show td 37 | show (TmDecl td) = show td 38 | 39 | 40 | 41 | 42 | 43 | -- | A term can be declared either with a simple equality, as in 44 | -- 45 | -- > let not : Bool -> Bool 46 | -- > = \b -> case b of 47 | -- > | True -> False 48 | -- > | False -> True 49 | -- > end 50 | -- > end 51 | -- 52 | -- or with a pattern match, as in 53 | -- 54 | -- > let not : Bool -> Bool where 55 | -- > | not True = False 56 | -- > | not False = True 57 | -- > end 58 | 59 | data TermDeclaration 60 | = TermDeclaration String Term Term 61 | | WhereDeclaration String Term [([Plicity],([String],[Pattern],Term))] 62 | | LetFamilyDeclaration String [DeclArg] Term 63 | | LetInstanceDeclaration Name [([Plicity],([String],[Pattern],Term))] 64 | 65 | instance Show TermDeclaration where 66 | show (TermDeclaration n ty def) = 67 | "let " ++ n ++ " : " ++ pretty ty ++ " = " ++ pretty def ++ " end" 68 | show (WhereDeclaration n ty preclauses) 69 | = "let " ++ n ++ " : " ++ pretty ty ++ " where " 70 | ++ intercalate " | " (map showPreclause preclauses) 71 | where 72 | show (LetFamilyDeclaration n args ty) = 73 | "let family " ++ n ++ " " ++ unwords (map show args) 74 | ++ " : " ++ pretty ty ++ " end" 75 | show (LetInstanceDeclaration n preclauses) = 76 | "let instance " ++ show n ++ " where " 77 | ++ intercalate " | " (map showPreclause preclauses) 78 | 79 | 80 | 81 | 82 | 83 | -- | Since two different kinds of declarations can be defined via pattern 84 | -- matching now, we extract out the utility function 'showPreclause' for that. 85 | 86 | showPreclause :: ([Plicity],([String],[Pattern],Term)) -> String 87 | showPreclause (plics,(_,ps,b)) 88 | = intercalate 89 | " || " 90 | (map showPattern (zip plics ps)) 91 | ++ " -> " ++ pretty b 92 | 93 | 94 | 95 | 96 | 97 | -- | Similarly we extract out 'showPattern'. 98 | 99 | showPattern :: (Plicity,Pattern) -> String 100 | showPattern (Expl,p) = parenthesize (Just (ConPatArg Expl)) p 101 | showPattern (Impl,p) = parenthesize (Just (ConPatArg Impl)) p 102 | 103 | 104 | 105 | 106 | 107 | -- | A type is declared with a GADT-like notation, however instead of giving 108 | -- the type of a constructor, as in Haskell or Agda, a constructor's signature 109 | -- is given via exemplified application, as in: 110 | -- 111 | -- @ 112 | -- data List (a : Type) where 113 | -- | Nil : List a 114 | -- | Cons (x : a) (xs : List a) : List a 115 | -- end 116 | -- @ 117 | -- 118 | -- Types with no constructors need no @where@: 119 | -- 120 | -- > data Void end 121 | 122 | data TypeDeclaration 123 | = TypeDeclaration String [DeclArg] [(String,ConSig)] 124 | | DataFamilyDeclaration String [DeclArg] 125 | | DataInstanceDeclaration Name [(String,ConSig)] 126 | 127 | instance Show TypeDeclaration where 128 | show (TypeDeclaration tycon tyargs []) = 129 | "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 130 | show (TypeDeclaration tycon tyargs alts) = 131 | "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " where" 132 | ++ concat [ "\n" ++ c ++ " : " ++ show sig | (c,sig) <- alts ] 133 | ++ "\nend" 134 | show (DataFamilyDeclaration tycon tyargs) = 135 | "data family " ++ tycon 136 | ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 137 | show (DataInstanceDeclaration tycon alts) = 138 | "data instance " ++ show tycon ++ " where" 139 | ++ concat [ "\n" ++ c ++ " : " ++ show sig 140 | | (c,sig) <- alts 141 | ] 142 | ++ "\nend" 143 | 144 | 145 | 146 | 147 | 148 | -- | Settings for hiding or using names from a module. 149 | 150 | data HidingUsing 151 | = Hiding [String] 152 | | Using [String] 153 | 154 | 155 | 156 | 157 | 158 | -- | Settings for opening a module's names for use. 159 | 160 | data OpenSettings 161 | = OpenSettings 162 | { openModule :: String 163 | , openAs :: Maybe String 164 | , openHidingUsing :: Maybe HidingUsing 165 | , openRenaming :: [(String,String)] 166 | } 167 | 168 | instance Show OpenSettings where 169 | show (OpenSettings m a hu r) 170 | = m ++ a' ++ hu' ++ r' 171 | where 172 | a' = case a of 173 | Nothing -> "" 174 | Just m' -> " as " ++ m' 175 | hu' = case hu of 176 | Nothing -> "" 177 | Just (Hiding ns) -> " hiding (" ++ intercalate "," ns ++ ")" 178 | Just (Using ns) -> " using (" ++ intercalate "," ns ++ ")" 179 | r' = case r of 180 | [] -> "" 181 | _ -> " renaming (" 182 | ++ intercalate 183 | ", " 184 | [ n ++ " to " ++ n' 185 | | (n,n') <- r 186 | ] 187 | ++ ")" 188 | 189 | 190 | 191 | 192 | 193 | -- | Modules with imports of other modules. 194 | 195 | data Module 196 | = Module String [OpenSettings] [Statement] 197 | 198 | instance Show Module where 199 | show (Module n [] stmts) 200 | = "module " ++ n ++ " where\n\n" 201 | ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 202 | show (Module n settings stmts) 203 | = "module " ++ n ++ " opening " ++ intercalate " | " (map show settings) 204 | ++ " where\n\n" ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 205 | 206 | 207 | 208 | 209 | 210 | -- | A program is just a series of 'Module's. 211 | 212 | newtype Program = Program [Module] 213 | 214 | instance Show Program where 215 | show (Program stmts) = intercalate "\n\n" (map show stmts) -------------------------------------------------------------------------------- /src/Quasiquote/Demo.sfp: -------------------------------------------------------------------------------- 1 | module Demo where 2 | 3 | data Bool where 4 | | True : Bool 5 | | False : Bool 6 | end 7 | 8 | let not : Bool -> Bool where 9 | | not True = False 10 | | not False = True 11 | end 12 | 13 | let ap : {a b : Type} -> Quoted (a -> b) -> Quoted a -> Quoted b where 14 | | ap f x = `(~f ~x) 15 | end 16 | 17 | end -------------------------------------------------------------------------------- /src/Quasiquote/Unification/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | -- This module defines the core types of a monadic elaborator. 13 | 14 | module Quasiquote.Unification.Elaborator where 15 | 16 | import Utils.Env 17 | import Utils.Plicity 18 | import Utils.Unifier 19 | import Utils.Vars 20 | import Quasiquote.Core.ConSig 21 | import Quasiquote.Core.Term 22 | 23 | import qualified Control.Lens as L 24 | import Control.Monad.State 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | -- The quote level judgment tracks how deeply nested under quotes a term is. 33 | 34 | data QLJ a = QLJ a Int 35 | deriving (Functor) 36 | 37 | 38 | 39 | 40 | 41 | -- | A signature is a collection of constructors together with their 42 | -- constructor signatures. This is used during type checking and elaboration 43 | -- to define the underlying type theory. 44 | 45 | type Signature = [((String,String),ConSig)] 46 | 47 | 48 | 49 | 50 | 51 | -- | A definition consists of a declared name together with its definition 52 | -- and its type. 53 | 54 | type Definitions = [((String,String),(Term,Term))] 55 | 56 | definitionsToEnvironment :: Definitions -> Env (String,String) Term 57 | definitionsToEnvironment defs = 58 | [ (x,m) | (x,(m,_)) <- defs ] 59 | 60 | 61 | 62 | 63 | 64 | -- | A context contains generated variables together with their display names, 65 | -- and their declared types. 66 | 67 | type Context = [(FreeVar,QLJ Term)] 68 | 69 | 70 | 71 | 72 | 73 | -- | Aliases are just maps from local names to absolute names. 74 | 75 | type Aliases = [(Either String (String,String), (String,String))] 76 | 77 | 78 | 79 | 80 | 81 | -- | Open functions have to story their pattern matching definitions so they 82 | -- can be re-built when new instances are added. 83 | 84 | type OpenFunction = ((String,String),(Term,[Plicity],CaseMotive,[Clause])) 85 | 86 | 87 | 88 | 89 | 90 | -- | The definition of the state to be carried by the type checking monad for 91 | -- this particular variant. 92 | 93 | data ElabState 94 | = ElabState 95 | { _signature :: Signature 96 | , _definitions :: Definitions 97 | , _context :: Context 98 | , _substitution :: Substitution TermF 99 | , _nextMeta :: MetaVar 100 | , _aliases :: Aliases 101 | , _moduleName :: String 102 | , _moduleNames :: [String] 103 | , _openData :: [(String,String)] 104 | , _openFunctions :: [OpenFunction] 105 | , _quoteLevel :: Int 106 | } 107 | L.makeLenses ''ElabState 108 | 109 | 110 | type Elaborator = StateT ElabState (Either String) 111 | 112 | 113 | type TypeChecker = Elaborator 114 | 115 | 116 | runElaborator :: Elaborator a 117 | -> Signature 118 | -> Definitions 119 | -> Context 120 | -> Aliases 121 | -> String 122 | -> [String] 123 | -> [(String,String)] 124 | -> [OpenFunction] 125 | -> Either String (a,ElabState) 126 | runElaborator e sig defs ctx als modname mods odata ofuns = 127 | runStateT 128 | e 129 | (ElabState sig defs ctx [] (MetaVar 0) als modname mods odata ofuns 0) 130 | 131 | 132 | runElaborator0 :: Elaborator a -> Either String (a,ElabState) 133 | runElaborator0 e = runElaborator e [] [] [] [] "" [] [] [] 134 | 135 | 136 | when' :: Elaborator a -> Elaborator () -> Elaborator () 137 | when' e1 e2 = do s <- get 138 | case runStateT e1 s of 139 | Left _ -> return () 140 | Right _ -> e2 -------------------------------------------------------------------------------- /src/Quasiquote/Unification/REPL.hs: -------------------------------------------------------------------------------- 1 | module Quasiquote.Unification.REPL where 2 | 3 | import Control.Monad.Reader (runReaderT) 4 | import System.IO 5 | 6 | import Utils.ABT 7 | import Utils.Env 8 | import Utils.Eval 9 | import Utils.Names 10 | import Utils.Pretty 11 | import Quasiquote.Core.ConSig 12 | import Quasiquote.Core.Evaluation 13 | import Quasiquote.Core.Parser 14 | import Quasiquote.Core.Term 15 | import Quasiquote.Unification.Elaborator 16 | import Quasiquote.Unification.Elaboration 17 | import Quasiquote.Unification.TypeChecking 18 | 19 | 20 | 21 | flushStr :: String -> IO () 22 | flushStr str = putStr str >> hFlush stdout 23 | 24 | readPrompt :: String -> IO String 25 | readPrompt prompt = flushStr prompt >> getLine 26 | 27 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 28 | until_ p prompt action = do 29 | result <- prompt 30 | if p result 31 | then return () 32 | else action result >> until_ p prompt action 33 | 34 | repl :: String -> IO () 35 | repl src = case loadProgram src of 36 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 37 | Right (sig,defs,ctx,env) 38 | -> do hSetBuffering stdin LineBuffering 39 | until_ (== ":quit") 40 | (readPrompt "$> ") 41 | (evalAndPrint sig defs ctx env) 42 | where 43 | loadProgram :: String 44 | -> Either String ( Signature 45 | , Definitions 46 | , Context 47 | , Env (String,String) Term 48 | ) 49 | loadProgram src 50 | = do prog <- parseProgram src 51 | (_,ElabState sig defs ctx _ _ _ _ _ _ _ _) <- 52 | runElaborator0 (elabProgram prog) 53 | let env = definitionsToEnvironment defs 54 | return (sig,defs,ctx,env) 55 | 56 | loadTerm :: Signature 57 | -> Definitions 58 | -> Context 59 | -> Env (String,String) Term 60 | -> String 61 | -> Either String Term 62 | loadTerm sig defs ctx env src 63 | = do tm0 <- parseTerm src 64 | let tm = freeToDefined (In . Defined . BareLocal) tm0 65 | als = [ (Right p,p) | (p,_) <- sig ] 66 | ++ [ (Right p,p) | (p,_) <- defs ] 67 | case runElaborator (infer tm) sig defs ctx als "" [] [] [] of 68 | Left e -> Left e 69 | Right ((etm,_),_) -> runReaderT (paramEval 0 etm) env 70 | 71 | evalAndPrint :: Signature 72 | -> Definitions 73 | -> Context 74 | -> Env (String,String) Term 75 | -> String 76 | -> IO () 77 | evalAndPrint _ _ _ _ "" = return () 78 | evalAndPrint sig defs ctx env src 79 | = case loadTerm sig defs ctx env src of 80 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 81 | Right v -> flushStr (pretty v ++ "\n") 82 | 83 | replFile :: String -> IO () 84 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Record/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | module Record.Core.ConSig where 10 | 11 | import Utils.ABT 12 | import Utils.Names 13 | import Utils.Plicity 14 | import Utils.Pretty (pretty) 15 | import Utils.Telescope 16 | import Record.Core.DeclArg 17 | import Record.Core.Term 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | data ConSig = ConSig [Plicity] (BindingTelescope (Scope TermF)) 26 | 27 | 28 | instance Show ConSig where 29 | show (ConSig plics (BindingTelescope ascs bsc)) = 30 | binders ++ " " ++ pretty (body bsc) 31 | where 32 | binders = 33 | unwords 34 | (zipWith 35 | (\n (plic,a) -> wrap plic (n ++ " : " ++ a)) 36 | ns 37 | (zip plics as)) 38 | as = map (pretty.body) ascs 39 | ns = names bsc 40 | 41 | wrap Expl x = "(" ++ x ++ ")" 42 | wrap Impl x = "{" ++ x ++ "}" 43 | 44 | 45 | conSigH :: [DeclArg] -> Term -> ConSig 46 | conSigH declas b = ConSig plics (bindingTelescopeH xs as b) 47 | where (plics,xas) = unzip [ (plic,(x,a)) | DeclArg plic x a <- declas ] 48 | (xs,as) = unzip xas 49 | 50 | 51 | freeToDefinedConSig :: ConSig -> ConSig 52 | freeToDefinedConSig (ConSig plics tele) = 53 | ConSig plics (fmap (freeToDefinedScope (In . Defined . BareLocal)) tele) -------------------------------------------------------------------------------- /src/Record/Core/DeclArg.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | module Record.Core.DeclArg where 6 | 7 | import Utils.Plicity 8 | import Utils.Pretty 9 | import Record.Core.Term 10 | 11 | 12 | 13 | data DeclArg = DeclArg Plicity String Term 14 | 15 | instance Show DeclArg where 16 | show (DeclArg Expl x t) = "(" ++ x ++ " : " ++ pretty t ++ ")" 17 | show (DeclArg Impl x t) = "{" ++ x ++ " : " ++ pretty t ++ "}" -------------------------------------------------------------------------------- /src/Record/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module defines what it means to be a program in the dependently 10 | -- typed lambda calculus. 11 | 12 | module Record.Core.Program where 13 | 14 | import Utils.Plicity 15 | import Utils.Pretty 16 | import Record.Core.ConSig 17 | import Record.Core.DeclArg 18 | import Record.Core.Term 19 | 20 | import Data.List (intercalate) 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | -- | A 'Statement' is either a 'TypeDeclaration' or a 'TermDeclaration'. 29 | 30 | data Statement 31 | = TyDecl TypeDeclaration 32 | | TmDecl TermDeclaration 33 | 34 | instance Show Statement where 35 | show (TyDecl td) = show td 36 | show (TmDecl td) = show td 37 | 38 | 39 | 40 | 41 | 42 | -- | A term can be declared either with a simple equality, as in 43 | -- 44 | -- > let not : Bool -> Bool 45 | -- > = \b -> case b of 46 | -- > | True -> False 47 | -- > | False -> True 48 | -- > end 49 | -- > end 50 | -- 51 | -- or with a pattern match, as in 52 | -- 53 | -- > let not : Bool -> Bool where 54 | -- > | not True = False 55 | -- > | not False = True 56 | -- > end 57 | 58 | data TermDeclaration 59 | = TermDeclaration String Term Term 60 | | WhereDeclaration String Term [([Plicity],([String],[Pattern],Term))] 61 | 62 | instance Show TermDeclaration where 63 | show (TermDeclaration n ty def) = 64 | "let " ++ n ++ " : " ++ pretty ty ++ " = " ++ pretty def ++ " end" 65 | show (WhereDeclaration n ty preclauses) 66 | = "let " ++ n ++ " : " ++ pretty ty ++ " where " 67 | ++ intercalate " | " (map showPreclause preclauses) 68 | where 69 | showPreclause :: ([Plicity],([String],[Pattern],Term)) -> String 70 | showPreclause (plics,(_,ps,b)) 71 | = intercalate 72 | " || " 73 | (map showPattern (zip plics ps)) 74 | ++ " -> " ++ pretty b 75 | 76 | showPattern :: (Plicity,Pattern) -> String 77 | showPattern (Expl,p) = parenthesize (Just (ConPatArg Expl)) p 78 | showPattern (Impl,p) = parenthesize (Just (ConPatArg Impl)) p 79 | 80 | 81 | 82 | 83 | 84 | -- | A type is declared with a GADT-like notation, however instead of giving 85 | -- the type of a constructor, as in Haskell or Agda, a constructor's signature 86 | -- is given via exemplified application, as in: 87 | -- 88 | -- @ 89 | -- data List (a : Type) where 90 | -- | Nil : List a 91 | -- | Cons (x : a) (xs : List a) : List a 92 | -- end 93 | -- @ 94 | -- 95 | -- Types with no constructors need no @where@: 96 | -- 97 | -- > data Void end 98 | 99 | data TypeDeclaration 100 | = TypeDeclaration String [DeclArg] [(String,ConSig)] 101 | 102 | instance Show TypeDeclaration where 103 | show (TypeDeclaration tycon tyargs []) = 104 | "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 105 | show (TypeDeclaration tycon tyargs alts) = 106 | "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " where" 107 | ++ concat [ "\n" ++ c ++ " : " ++ show sig | (c,sig) <- alts ] 108 | ++ "\nend" 109 | 110 | 111 | 112 | 113 | 114 | -- | Settings for hiding or using names from a module. 115 | 116 | data HidingUsing 117 | = Hiding [String] 118 | | Using [String] 119 | 120 | 121 | 122 | 123 | 124 | -- | Settings for opening a module's names for use. 125 | 126 | data OpenSettings 127 | = OpenSettings 128 | { openModule :: String 129 | , openAs :: Maybe String 130 | , openHidingUsing :: Maybe HidingUsing 131 | , openRenaming :: [(String,String)] 132 | } 133 | 134 | instance Show OpenSettings where 135 | show (OpenSettings m a hu r) 136 | = m ++ a' ++ hu' ++ r' 137 | where 138 | a' = case a of 139 | Nothing -> "" 140 | Just m' -> " as " ++ m' 141 | hu' = case hu of 142 | Nothing -> "" 143 | Just (Hiding ns) -> " hiding (" ++ intercalate "," ns ++ ")" 144 | Just (Using ns) -> " using (" ++ intercalate "," ns ++ ")" 145 | r' = case r of 146 | [] -> "" 147 | _ -> " renaming (" 148 | ++ intercalate 149 | ", " 150 | [ n ++ " to " ++ n' 151 | | (n,n') <- r 152 | ] 153 | ++ ")" 154 | 155 | 156 | 157 | 158 | 159 | -- | Modules with imports of other modules. 160 | 161 | data Module 162 | = Module String [OpenSettings] [Statement] 163 | 164 | instance Show Module where 165 | show (Module n [] stmts) 166 | = "module " ++ n ++ " where\n\n" 167 | ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 168 | show (Module n settings stmts) 169 | = "module " ++ n ++ " opening " ++ intercalate " | " (map show settings) 170 | ++ " where\n\n" ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 171 | 172 | 173 | 174 | 175 | 176 | -- | A program is just a series of 'Module's. 177 | 178 | newtype Program = Program [Module] 179 | 180 | instance Show Program where 181 | show (Program stmts) = intercalate "\n\n" (map show stmts) -------------------------------------------------------------------------------- /src/Record/Demo.sfp: -------------------------------------------------------------------------------- 1 | module Demo where 2 | 3 | data Nat where 4 | | Zero : Nat 5 | | Suc (n : Nat) : Nat 6 | end 7 | 8 | data Even (n : Nat) where 9 | | ZeroEven : Even Zero 10 | | SucSucEven {n : Nat} (p : Even n) : Even (Suc (Suc n)) 11 | end 12 | 13 | let foo : (x : Nat) -> Rec { p : Nat } 14 | = \x -> { p = x } 15 | end 16 | 17 | end -------------------------------------------------------------------------------- /src/Record/Unification/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -- This module defines the core types of a monadic elaborator. 12 | 13 | module Record.Unification.Elaborator where 14 | 15 | import Utils.Env 16 | import Utils.Unifier 17 | import Utils.Vars 18 | import Record.Core.ConSig 19 | import Record.Core.Term 20 | 21 | import qualified Control.Lens as L 22 | import Control.Monad.State 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | -- | A signature is a collection of constructors together with their 31 | -- constructor signatures. This is used during type checking and elaboration 32 | -- to define the underlying type theory. 33 | 34 | type Signature = [((String,String),ConSig)] 35 | 36 | 37 | 38 | 39 | 40 | -- | A definition consists of a declared name together with its definition 41 | -- and its type. 42 | 43 | type Definitions = [((String,String),(Term,Term))] 44 | 45 | definitionsToEnvironment :: Definitions -> Env (String,String) Term 46 | definitionsToEnvironment defs = 47 | [ (x,m) | (x,(m,_)) <- defs ] 48 | 49 | 50 | 51 | 52 | 53 | -- | A context contains generated variables together with their display names, 54 | -- and their declared types. 55 | 56 | type Context = [(FreeVar,Term)] 57 | 58 | 59 | 60 | 61 | 62 | -- | Aliases are just maps from local names to absolute names. 63 | 64 | type Aliases = [(Either String (String,String), (String,String))] 65 | 66 | 67 | 68 | 69 | 70 | -- | The definition of the state to be carried by the type checking monad for 71 | -- this particular variant. 72 | 73 | data ElabState 74 | = ElabState 75 | { _signature :: Signature 76 | , _definitions :: Definitions 77 | , _context :: Context 78 | , _substitution :: Substitution TermF 79 | , _nextMeta :: MetaVar 80 | , _aliases :: Aliases 81 | , _moduleName :: String 82 | , _moduleNames :: [String] 83 | } 84 | L.makeLenses ''ElabState 85 | 86 | 87 | type Elaborator = StateT ElabState (Either String) 88 | 89 | 90 | type TypeChecker = Elaborator 91 | 92 | 93 | runElaborator :: Elaborator a 94 | -> Signature 95 | -> Definitions 96 | -> Context 97 | -> Aliases 98 | -> String 99 | -> [String] 100 | -> Either String (a,ElabState) 101 | runElaborator e sig defs ctx als modname mods = 102 | runStateT e (ElabState sig defs ctx [] (MetaVar 0) als modname mods) 103 | 104 | 105 | runElaborator0 :: Elaborator a -> Either String (a,ElabState) 106 | runElaborator0 e = runElaborator e [] [] [] [] "" [] 107 | 108 | 109 | when' :: Elaborator a -> Elaborator () -> Elaborator () 110 | when' e1 e2 = do s <- get 111 | case runStateT e1 s of 112 | Left _ -> return () 113 | Right _ -> e2 -------------------------------------------------------------------------------- /src/Record/Unification/REPL.hs: -------------------------------------------------------------------------------- 1 | module Record.Unification.REPL where 2 | 3 | import Control.Monad.Reader (runReaderT) 4 | import System.IO 5 | 6 | import Utils.ABT 7 | import Utils.Env 8 | import Utils.Eval 9 | import Utils.Names 10 | import Utils.Pretty 11 | import Record.Core.ConSig 12 | import Record.Core.Evaluation 13 | import Record.Core.Parser 14 | import Record.Core.Term 15 | import Record.Unification.Elaborator 16 | import Record.Unification.Elaboration 17 | import Record.Unification.TypeChecking 18 | 19 | 20 | 21 | flushStr :: String -> IO () 22 | flushStr str = putStr str >> hFlush stdout 23 | 24 | readPrompt :: String -> IO String 25 | readPrompt prompt = flushStr prompt >> getLine 26 | 27 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 28 | until_ p prompt action = do 29 | result <- prompt 30 | if p result 31 | then return () 32 | else action result >> until_ p prompt action 33 | 34 | repl :: String -> IO () 35 | repl src = case loadProgram src of 36 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 37 | Right (sig,defs,ctx,env) 38 | -> do hSetBuffering stdin LineBuffering 39 | until_ (== ":quit") 40 | (readPrompt "$> ") 41 | (evalAndPrint sig defs ctx env) 42 | where 43 | loadProgram :: String 44 | -> Either String ( Signature 45 | , Definitions 46 | , Context 47 | , Env (String,String) Term 48 | ) 49 | loadProgram src 50 | = do prog <- parseProgram src 51 | (_,ElabState sig defs ctx _ _ _ _ _) <- 52 | runElaborator0 (elabProgram prog) 53 | let env = definitionsToEnvironment defs 54 | return (sig,defs,ctx,env) 55 | 56 | loadTerm :: Signature 57 | -> Definitions 58 | -> Context 59 | -> Env (String,String) Term 60 | -> String 61 | -> Either String Term 62 | loadTerm sig defs ctx env src 63 | = do tm0 <- parseTerm src 64 | let tm = freeToDefined (In . Defined . BareLocal) tm0 65 | als = [ (Right p,p) | (p,_) <- sig ] 66 | ++ [ (Right p,p) | (p,_) <- defs ] 67 | case runElaborator (infer tm) sig defs ctx als "" [] of 68 | Left e -> Left e 69 | Right ((etm,_),_) -> runReaderT (eval etm) env 70 | 71 | evalAndPrint :: Signature 72 | -> Definitions 73 | -> Context 74 | -> Env (String,String) Term 75 | -> String 76 | -> IO () 77 | evalAndPrint _ _ _ _ "" = return () 78 | evalAndPrint sig defs ctx env src 79 | = case loadTerm sig defs ctx env src of 80 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 81 | Right v -> flushStr (pretty v ++ "\n") 82 | 83 | replFile :: String -> IO () 84 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Require/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | module Require.Core.ConSig where 10 | 11 | import Utils.ABT 12 | import Utils.Names 13 | import Utils.Plicity 14 | import Utils.Pretty (pretty) 15 | import Utils.Telescope 16 | import Require.Core.DeclArg 17 | import Require.Core.Term 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | data ConSig = ConSig [Plicity] (BindingTelescope (Scope TermF)) 26 | 27 | 28 | instance Show ConSig where 29 | show (ConSig plics (BindingTelescope ascs bsc)) = 30 | binders ++ " " ++ pretty (body bsc) 31 | where 32 | binders = 33 | unwords 34 | (zipWith 35 | (\n (plic,a) -> wrap plic (n ++ " : " ++ a)) 36 | ns 37 | (zip plics as)) 38 | as = map (pretty.body) ascs 39 | ns = names bsc 40 | 41 | wrap Expl x = "(" ++ x ++ ")" 42 | wrap Impl x = "{" ++ x ++ "}" 43 | 44 | 45 | conSigH :: [DeclArg] -> Term -> ConSig 46 | conSigH declas b = ConSig plics (bindingTelescopeH xs as b) 47 | where (plics,xas) = unzip [ (plic,(x,a)) | DeclArg plic x a <- declas ] 48 | (xs,as) = unzip xas 49 | 50 | 51 | freeToDefinedConSig :: ConSig -> ConSig 52 | freeToDefinedConSig (ConSig plics tele) = 53 | ConSig plics (fmap (freeToDefinedScope (In . Defined . BareLocal)) tele) -------------------------------------------------------------------------------- /src/Require/Core/DeclArg.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | module Require.Core.DeclArg where 6 | 7 | import Utils.Plicity 8 | import Utils.Pretty 9 | import Require.Core.Term 10 | 11 | 12 | 13 | data DeclArg = DeclArg Plicity String Term 14 | 15 | instance Show DeclArg where 16 | show (DeclArg Expl x t) = "(" ++ x ++ " : " ++ pretty t ++ ")" 17 | show (DeclArg Impl x t) = "{" ++ x ++ " : " ++ pretty t ++ "}" -------------------------------------------------------------------------------- /src/Require/Core/Decontinuization.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module defines the tools for decontinuizing terms. 10 | 11 | module Require.Core.Decontinuization where 12 | 13 | import Utils.ABT hiding (shift) 14 | import Utils.Vars 15 | import Require.Core.Term 16 | 17 | import Control.Monad.Reader 18 | import Control.Monad.State 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | -- | Binary composition to make applicative style more convenient. 28 | 29 | (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d 30 | f .: g = \x y -> f (g x y) 31 | 32 | 33 | -- | Trinary composition to make applicative style more convenient. 34 | 35 | (.::) :: (d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e 36 | f .:: g = \x y z -> f (g x y z) 37 | 38 | 39 | 40 | 41 | 42 | -- | A @Continuer@ is a higher-order representation of the body of a shift, 43 | -- which contains continue points. A term such as @foo x * continue x@ would 44 | -- correspond to a function @\c -> foo x * c x@. We can therefore represent 45 | -- this by using a reader. 46 | 47 | type Continuer a = Reader (Scope TermF) a 48 | 49 | 50 | -- | This is the core of what makes a continuer go. Every constructor is 51 | -- propagated algebraically except @Continue@ which is swapped for @continue@, 52 | -- constructing the basic @Continuer@. 53 | 54 | continue :: Term -> Continuer Term 55 | continue x = do sc <- ask 56 | return (instantiate sc [x]) 57 | 58 | 59 | 60 | 61 | 62 | -- | We transform a term into a @Continuer@ by just replacing every maximal 63 | -- term @Continue x@ with @continue x@, leaving everything else alone. 64 | 65 | makeContinuer :: Term -> Continuer Term 66 | makeContinuer (Var v) = pure (Var v) 67 | makeContinuer (In (Continue m)) = continue (instantiate0 m) 68 | makeContinuer (In x) = In <$> traverse (underF makeContinuer) x 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | -- | Another important type is @Shifter@. This is a tyoe that makes it easy 77 | -- to replace the @Shift@ terms with their appropriate reset value. However, 78 | -- since there are multiple shifts inside any given reset, we track which 79 | -- shifted term we're at when we replace it, hence the use of @State@. 80 | -- Additionally, because the replacement terms are not yet known, we instead 81 | -- need to compose up a function that will pick the appropriate one from a 82 | -- list. 83 | 84 | newtype Shifter a = Shifter { runShifter :: State Int (a, [(String,Term)]) } 85 | 86 | 87 | -- | A shifter is evaluated by evaluating it's state starting with 0. 88 | 89 | evalShifter :: Shifter a -> (a, [(String,Term)]) 90 | evalShifter (Shifter x) = evalState x 0 91 | 92 | 93 | instance Functor Shifter where 94 | fmap f x = Shifter $ do 95 | (x',nes) <- runShifter x 96 | return (f x', nes) 97 | 98 | 99 | instance Applicative Shifter where 100 | pure x = Shifter (pure (x, [])) 101 | f <*> x = Shifter $ do 102 | (f',nes) <- runShifter f 103 | (x',nes') <- runShifter x 104 | return (f' x', nes ++ nes') 105 | 106 | 107 | 108 | 109 | -- | The @shift@ function is the core of shifting behavior, much like 110 | -- @continue@ is the core of continuing behavior. @shift@ will put its term 111 | -- into the list of shifted terms to return, and the functiont to look up its 112 | -- replacement does so by projecting out the current index according to the 113 | -- state, which is itself incremented. 114 | 115 | shift :: Term -> Shifter Term 116 | shift x = Shifter $ do 117 | i <- get 118 | put (i+1) 119 | let n = "auto_shift_" ++ show i 120 | return (Var (Free (FreeVar n)), [(n,x)]) 121 | 122 | 123 | 124 | 125 | 126 | -- | We transform a term into a @Shifter@ by just replacing every maximal 127 | -- term @Shift res x@ with @shift x@, leaving everything else alone. 128 | 129 | makeShifter :: Term -> Shifter Term 130 | makeShifter (Var v) = pure (Var v) 131 | makeShifter (In (Shift _ m)) = shift (instantiate0 m) 132 | makeShifter (In x) = In <$> traverse (underF makeShifter) x 133 | 134 | 135 | 136 | 137 | 138 | -- | We can reset a number of shifts by collecting up the maximal shifts in 139 | -- an expression, converting their bodies to the appropriate continuers, 140 | -- then sequencing the corresponding continuized values, and then running that 141 | -- sequenced continuized value on the continuation. We repeat this until there 142 | -- are no shifts to reset, at which point we're done'. 143 | 144 | reset :: Term -> Term 145 | reset x 146 | | null shifts = m 147 | | otherwise = reset (foldr abstractor m shifts) 148 | where 149 | (m,shifts) = evalShifter (makeShifter x) 150 | abstractor (n,x') m' = runReader (makeContinuer x') (scope [n] m') 151 | 152 | 153 | 154 | 155 | 156 | -- | A term is decontinuized by resetting every reset term in a bottom up way. 157 | 158 | decontinuize :: Term -> Term 159 | decontinuize (Var v) = Var v 160 | decontinuize (In (Reset _ m)) = reset (decontinuize (instantiate0 m)) 161 | decontinuize (In x) = In (fmap (under decontinuize) x) -------------------------------------------------------------------------------- /src/Require/Demo.sfp: -------------------------------------------------------------------------------- 1 | module Demo where 2 | 3 | data Foo end 4 | 5 | data Bar (f : Foo) end 6 | 7 | -- both of these examples will type check, but only @ex0@ will be solvable. 8 | -- it will solve @x@ to be @y@, so the entire thing solves to 9 | -- @(y : Foo) -> Bar y@ 10 | 11 | let ex0 : Quoted Type 12 | = `((y : Foo) -> require x : Foo in Bar x) 13 | end 14 | 15 | let ex1 : Quoted Foo 16 | = `(require x : Foo in x) 17 | end 18 | 19 | end -------------------------------------------------------------------------------- /src/Require/Unification/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | -- This module defines the core types of a monadic elaborator. 13 | 14 | module Require.Unification.Elaborator where 15 | 16 | import Utils.Env 17 | import Utils.Plicity 18 | import Utils.Unifier 19 | import Utils.Vars 20 | import Require.Core.ConSig 21 | import Require.Core.Term 22 | 23 | import qualified Control.Lens as L 24 | import Control.Monad.State 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | -- The quote level judgment tracks how deeply nested under quotes a term is. 33 | 34 | data QLJ a = QLJ a Int 35 | deriving (Functor) 36 | 37 | 38 | 39 | 40 | 41 | -- | A signature is a collection of constructors together with their 42 | -- constructor signatures. This is used during type checking and elaboration 43 | -- to define the underlying type theory. 44 | 45 | type Signature = [((String,String),ConSig)] 46 | 47 | 48 | 49 | 50 | 51 | -- | A definition consists of a declared name together with its definition 52 | -- and its type. 53 | 54 | type Definitions = [((String,String),(Term,Term))] 55 | 56 | definitionsToEnvironment :: Definitions -> Env (String,String) Term 57 | definitionsToEnvironment defs = 58 | [ (x,m) | (x,(m,_)) <- defs ] 59 | 60 | 61 | 62 | 63 | 64 | -- | A context contains generated variables together with their display names, 65 | -- and their declared types. 66 | 67 | type Context = [(FreeVar,QLJ Term)] 68 | 69 | 70 | 71 | 72 | 73 | -- | Aliases are just maps from local names to absolute names. 74 | 75 | type Aliases = [(Either String (String,String), (String,String))] 76 | 77 | 78 | 79 | 80 | 81 | -- | Open functions have to story their pattern matching definitions so they 82 | -- can be re-built when new instances are added. 83 | 84 | type OpenFunction = ((String,String),(Term,[Plicity],CaseMotive,[Clause])) 85 | 86 | 87 | 88 | 89 | 90 | -- | Declared reset points are just a collection of reset point names with 91 | -- their declared types. 92 | 93 | type ResetPoints = [(String,(Term,Term))] 94 | 95 | 96 | 97 | 98 | 99 | -- | The definition of the state to be carried by the type checking monad for 100 | -- this particular variant. 101 | 102 | data ElabState 103 | = ElabState 104 | { _signature :: Signature 105 | , _definitions :: Definitions 106 | , _context :: Context 107 | , _substitution :: Substitution TermF 108 | , _nextMeta :: MetaVar 109 | , _aliases :: Aliases 110 | , _moduleName :: String 111 | , _moduleNames :: [String] 112 | , _openData :: [(String,String)] 113 | , _openFunctions :: [OpenFunction] 114 | , _quoteLevel :: Int 115 | , _resetPoints :: ResetPoints 116 | , _resetPointsInScope :: [String] 117 | , _shiftsInScope :: [String] 118 | } 119 | L.makeLenses ''ElabState 120 | 121 | 122 | type Elaborator = StateT ElabState (Either String) 123 | 124 | 125 | type TypeChecker = Elaborator 126 | 127 | 128 | runElaborator :: Elaborator a 129 | -> Signature 130 | -> Definitions 131 | -> Context 132 | -> Aliases 133 | -> String 134 | -> [String] 135 | -> [(String,String)] 136 | -> [OpenFunction] 137 | -> Either String (a,ElabState) 138 | runElaborator e sig defs ctx als modname mods odata ofuns = 139 | runStateT 140 | e 141 | (ElabState sig defs ctx [] (MetaVar 0) als modname mods odata ofuns 0 [] [] []) 142 | 143 | 144 | runElaborator0 :: Elaborator a -> Either String (a,ElabState) 145 | runElaborator0 e = runElaborator e [] [] [] [] "" [] [] [] 146 | 147 | 148 | when' :: Elaborator a -> Elaborator () -> Elaborator () 149 | when' e1 e2 = do s <- get 150 | case runStateT e1 s of 151 | Left _ -> return () 152 | Right _ -> e2 -------------------------------------------------------------------------------- /src/Require/Unification/REPL.hs: -------------------------------------------------------------------------------- 1 | module Require.Unification.REPL where 2 | 3 | import Control.Monad.Reader (runReaderT) 4 | import System.IO 5 | import Utils.ABT 6 | import Utils.Env 7 | import Utils.Eval 8 | import Utils.Names 9 | import Utils.Pretty 10 | import Require.Core.ConSig 11 | import Require.Core.Evaluation 12 | import Require.Core.Parser 13 | import Require.Core.Term 14 | import Require.Unification.Elaborator 15 | import Require.Unification.Elaboration 16 | import Require.Unification.TypeChecking 17 | 18 | 19 | 20 | flushStr :: String -> IO () 21 | flushStr str = putStr str >> hFlush stdout 22 | 23 | readPrompt :: String -> IO String 24 | readPrompt prompt = flushStr prompt >> getLine 25 | 26 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 27 | until_ p prompt action = do 28 | result <- prompt 29 | if p result 30 | then return () 31 | else action result >> until_ p prompt action 32 | 33 | repl :: String -> IO () 34 | repl src = case loadProgram src of 35 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 36 | Right (sig,defs,ctx,env) 37 | -> do hSetBuffering stdin LineBuffering 38 | until_ (== ":quit") 39 | (readPrompt "$> ") 40 | (evalAndPrint sig defs ctx env) 41 | where 42 | loadProgram :: String 43 | -> Either String ( Signature 44 | , Definitions 45 | , Context 46 | , Env (String,String) Term 47 | ) 48 | loadProgram src 49 | = do prog <- parseProgram src 50 | (_,ElabState sig defs ctx _ _ _ _ _ _ _ _ _ _ _) <- 51 | runElaborator0 (elabProgram prog) 52 | let env = definitionsToEnvironment defs 53 | return (sig,defs,ctx,env) 54 | 55 | loadTerm :: Signature 56 | -> Definitions 57 | -> Context 58 | -> Env (String,String) Term 59 | -> String 60 | -> Either String Term 61 | loadTerm sig defs ctx env src 62 | = do tm0 <- parseTerm src 63 | let tm = freeToDefined (In . Defined . BareLocal) tm0 64 | als = [ (Right p,p) | (p,_) <- sig ] 65 | ++ [ (Right p,p) | (p,_) <- defs ] 66 | case runElaborator (infer tm) sig defs ctx als "" [] [] [] of 67 | Left e -> Left e 68 | Right ((etm,_),_) -> runReaderT (paramEval 0 etm) env 69 | 70 | evalAndPrint :: Signature 71 | -> Definitions 72 | -> Context 73 | -> Env (String,String) Term 74 | -> String 75 | -> IO () 76 | evalAndPrint _ _ _ _ "" = return () 77 | evalAndPrint sig defs ctx env src 78 | = case loadTerm sig defs ctx env src of 79 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 80 | Right v -> flushStr (pretty v ++ "\n") 81 | 82 | replFile :: String -> IO () 83 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Simple/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module implements constructor signatures, for data declarations. 10 | 11 | module Simple.Core.ConSig where 12 | 13 | import Utils.Pretty (pretty) 14 | import Simple.Core.Type 15 | 16 | import Data.List (intercalate) 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | -- | A constructor signature in this variant is simply a list of argument 25 | -- types and a return type. 26 | 27 | data ConSig = ConSig [Type] Type 28 | 29 | 30 | instance Show ConSig where 31 | show (ConSig as r) = 32 | "(" ++ intercalate "," (map pretty as) ++ ")" ++ pretty r -------------------------------------------------------------------------------- /src/Simple/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | 7 | 8 | 9 | 10 | -- | This module defines how to evaluate terms in the simply typed lambda 11 | -- calculus w/ non-parametric user defined types (eg Bool, Nat). 12 | 13 | module Simple.Core.Evaluation where 14 | 15 | import Utils.ABT 16 | import Utils.Env 17 | import Utils.Eval 18 | import Utils.Pretty (pretty) 19 | import Simple.Core.Term 20 | 21 | import Control.Monad.Except 22 | 23 | 24 | 25 | 26 | 27 | -- | Pattern matching for case expressions. 28 | 29 | matchPattern :: Pattern -> Term -> Maybe [Term] 30 | matchPattern (Var _) v = Just [v] 31 | matchPattern (In (ConPat c ps)) (In (Con c' as)) 32 | | c == c' && length ps == length as = 33 | fmap concat (zipWithM matchPattern (map body ps) (map body as)) 34 | matchPattern _ _ = Nothing 35 | 36 | matchPatterns :: [Pattern] -> [Term] -> Maybe [Term] 37 | matchPatterns ps zs = fmap concat (zipWithM matchPattern ps zs) 38 | 39 | matchClauses :: [Clause] -> [Term] -> Maybe Term 40 | matchClauses [] _ = 41 | Nothing 42 | matchClauses (Clause pscs sc:cs) vs = 43 | case matchPatterns (map body pscs) vs of 44 | Nothing -> matchClauses cs vs 45 | Just xs -> Just (instantiate sc xs) 46 | 47 | 48 | 49 | 50 | 51 | -- | Standard eager evaluation. 52 | 53 | instance Eval (Env String Term) Term where 54 | eval (Var v) = 55 | return $ Var v 56 | eval (In (Defined x)) = 57 | do env <- environment 58 | case lookup x env of 59 | Nothing -> throwError $ "Unknown constant/defined term: " ++ x 60 | Just m -> return m 61 | eval (In (Ann m _)) = 62 | eval (instantiate0 m) 63 | eval (In (Lam sc)) = 64 | return $ In (Lam sc) 65 | eval (In (App f a)) = 66 | do ef <- eval (instantiate0 f) 67 | ea <- eval (instantiate0 a) 68 | case ef of 69 | In (Lam sc) -> eval (instantiate sc [ea]) 70 | _ -> return $ appH ef ea 71 | eval (In (Con c as)) = 72 | do eas <- mapM (eval . instantiate0) as 73 | return $ conH c eas 74 | eval (In (Case ms cs)) = 75 | do ems <- mapM (eval . instantiate0) ms 76 | case matchClauses cs ems of 77 | Nothing -> throwError $ "Incomplete pattern match: " ++ pretty (In (Case ms cs)) 78 | Just b -> eval b -------------------------------------------------------------------------------- /src/Simple/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | -- | This module defines what it means to be a program in the simply typed 8 | -- lambda calculus w/ non-parametric user defined types (eg Bool, Nat). 9 | 10 | module Simple.Core.Program where 11 | 12 | import Utils.Pretty 13 | import Simple.Core.ConSig 14 | import Simple.Core.Term 15 | import Simple.Core.Type 16 | 17 | import Data.List (intercalate) 18 | 19 | 20 | 21 | 22 | 23 | -- | A program is just a series of 'Statement's. 24 | 25 | newtype Program = Program [Statement] 26 | 27 | instance Show Program where 28 | show (Program stmts) = intercalate "\n\n" (map show stmts) 29 | 30 | 31 | 32 | 33 | 34 | -- | A 'Statement' is either a 'TypeDeclaration' or a 'TermDeclaration'. 35 | 36 | data Statement 37 | = TyDecl TypeDeclaration 38 | | TmDecl TermDeclaration 39 | 40 | instance Show Statement where 41 | show (TyDecl td) = show td 42 | show (TmDecl td) = show td 43 | 44 | 45 | 46 | 47 | 48 | -- | A term can be declared either with a simple equality, as in 49 | -- 50 | -- > let not : Bool -> Bool 51 | -- > = \b -> case b of 52 | -- > | True -> False 53 | -- > | False -> True 54 | -- > end 55 | -- > end 56 | -- 57 | -- or with a pattern match, as in 58 | -- 59 | -- > let not : Bool -> Bool where 60 | -- > | not True = False 61 | -- > | not False = True 62 | -- > end 63 | 64 | data TermDeclaration 65 | = TermDeclaration String Type Term 66 | | WhereDeclaration String Type [([Pattern],[String],Term)] 67 | 68 | instance Show TermDeclaration where 69 | show (TermDeclaration n ty def) = 70 | "let " ++ n ++ " : " ++ pretty ty ++ " = " ++ pretty def ++ " end" 71 | show (WhereDeclaration n ty preclauses) = 72 | "let " ++ n ++ " : " ++ pretty ty ++ " where " 73 | ++ intercalate " | " (map showPreclause preclauses) 74 | where 75 | showPreclause :: ([Pattern],[String],Term) -> String 76 | showPreclause (ps,_,b) = 77 | intercalate " || " (map pretty ps) ++ " -> " ++ pretty b 78 | 79 | 80 | 81 | 82 | 83 | -- | A type is declared with Haskell-like notation, as in 84 | -- 85 | -- > data Bool = True | False end 86 | -- 87 | -- Types with no constructors need no @=@: 88 | -- 89 | -- > data Void end 90 | 91 | data TypeDeclaration 92 | = TypeDeclaration String [(String,ConSig)] 93 | 94 | instance Show TypeDeclaration where 95 | show (TypeDeclaration tycon []) = 96 | "data " ++ tycon ++ " end" 97 | show (TypeDeclaration tycon alts) = 98 | "data " ++ tycon ++ " = " 99 | ++ intercalate " | " [ showAlt c as | (c, ConSig as _) <- alts ] 100 | ++ " end" 101 | where 102 | showAlt :: String -> [Type] -> String 103 | showAlt c [] = c 104 | showAlt c as = c ++ " " ++ unwords (map pretty as) -------------------------------------------------------------------------------- /src/Simple/Core/Term.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | 10 | 11 | 12 | 13 | 14 | -- | The terms of the simply typed lambda calculus w/ non-parametric user 15 | -- defined types (eg Bool, Nat). 16 | 17 | module Simple.Core.Term where 18 | 19 | import Simple.Core.Type 20 | 21 | import Utils.ABT 22 | import Utils.Pretty 23 | 24 | import Data.List (intercalate) 25 | 26 | 27 | 28 | 29 | 30 | -- | There are five kinds of terms, an annotated term @M : T@, a lambda term 31 | -- @\\x -> M@, an application term @M N@, a constructor term @C M0 ... Mn@, and 32 | -- a case term @case M0 || ... || Mn of p0* -> N0 | ... | pm* -> Nm end@. 33 | 34 | data TermF r 35 | = Defined String 36 | | Ann r Type 37 | | Lam r 38 | | App r r 39 | | Con String [r] 40 | | Case [r] [ClauseF r] 41 | deriving (Functor,Foldable) 42 | 43 | 44 | type Term = ABT TermF 45 | 46 | 47 | -- | Clauses are a subsort of terms that has bunch of pattern scopes together 48 | -- with a clause body. 49 | 50 | data ClauseF r = Clause [Scope PatternF] r 51 | deriving (Functor,Foldable) 52 | 53 | 54 | type Clause = ClauseF (Scope TermF) 55 | 56 | 57 | -- | Patterns are only constructor patterns, with some number of pattern args. 58 | 59 | data PatternF r = ConPat String [r] 60 | deriving (Functor,Foldable,Traversable) 61 | 62 | 63 | type Pattern = ABT PatternF 64 | 65 | 66 | defined :: String -> Term 67 | defined n = In (Defined n) 68 | 69 | annH :: Term -> Type -> Term 70 | annH m t = In (Ann (scope [] m) t) 71 | 72 | lamH :: String -> Term -> Term 73 | lamH v b = In (Lam (scope [v] b)) 74 | 75 | appH :: Term -> Term -> Term 76 | appH f x = In (App (scope [] f) (scope [] x)) 77 | 78 | conH :: String -> [Term] -> Term 79 | conH c xs = In (Con c (map (scope []) xs)) 80 | 81 | caseH :: [Term] -> [Clause] -> Term 82 | caseH as cs = In (Case (map (scope []) as) cs) 83 | 84 | clauseH :: [String] -> [Pattern] -> Term -> Clause 85 | clauseH vs ps b = Clause (map (scope vs) ps) (scope vs b) 86 | 87 | conPatH :: String -> [Pattern] -> Pattern 88 | conPatH c xs = In (ConPat c (map (scope []) xs)) 89 | 90 | 91 | 92 | 93 | 94 | -- | Terms have a variety of locations that can potentially be sites of 95 | -- de-parenthesization. 96 | 97 | data TermParenLoc 98 | = AnnTerm 99 | | LamBody | AppFun | AppArg 100 | | ConArg | CaseArg | ClauseBody 101 | deriving (Eq) 102 | 103 | 104 | instance Parens Term where 105 | type Loc Term = TermParenLoc 106 | 107 | parenLoc (Var _) = 108 | [AnnTerm,LamBody,AppFun,AppArg,ConArg,CaseArg,ClauseBody] 109 | parenLoc (In (Defined _)) = 110 | [AnnTerm,LamBody,AppFun,AppArg,ConArg,CaseArg,ClauseBody] 111 | parenLoc (In (Ann _ _)) = 112 | [LamBody,CaseArg,ClauseBody] 113 | parenLoc (In (Lam _)) = 114 | [LamBody,CaseArg,ClauseBody] 115 | parenLoc (In (App _ _)) = 116 | [AnnTerm,LamBody,AppFun,CaseArg,ClauseBody] 117 | parenLoc (In (Con _ [])) = 118 | [AnnTerm,LamBody,AppFun,AppArg,ConArg,CaseArg,ClauseBody] 119 | parenLoc (In (Con _ _)) = 120 | [AnnTerm,LamBody,CaseArg,ClauseBody] 121 | parenLoc (In (Case _ _)) = 122 | [LamBody,ClauseBody] 123 | 124 | parenRec (Var v) = 125 | name v 126 | parenRec (In (Defined n)) = n 127 | parenRec (In (Ann m t)) = 128 | parenthesize (Just AnnTerm) (instantiate0 m) 129 | ++ " : " 130 | ++ pretty t 131 | parenRec (In (Lam sc)) = 132 | "\\" ++ unwords (names sc) 133 | ++ " -> " 134 | ++ parenthesize (Just LamBody) 135 | (body sc) 136 | parenRec (In (App f a)) = 137 | parenthesize (Just AppFun) (instantiate0 f) 138 | ++ " " 139 | ++ parenthesize (Just AppArg) (instantiate0 a) 140 | parenRec (In (Con c [])) = 141 | c 142 | parenRec (In (Con c as)) = 143 | c ++ " " 144 | ++ intercalate 145 | " " 146 | (map (parenthesize (Just ConArg) . instantiate0) as) 147 | parenRec (In (Case as cs)) = 148 | "case " 149 | ++ intercalate 150 | " || " 151 | (map (parenthesize (Just CaseArg) . instantiate0) as) 152 | ++ " of " 153 | ++ intercalate " | " (map auxClause cs) ++ " end" 154 | where 155 | auxClause :: Clause -> String 156 | auxClause (Clause pscs sc) = 157 | intercalate " || " 158 | (map (parenthesize Nothing . body) pscs) 159 | ++ " -> " 160 | ++ parenthesize (Just ClauseBody) (body sc) 161 | 162 | 163 | 164 | 165 | 166 | -- | Pattern locations are even simpler, as there's only one: constructor arg. 167 | 168 | data PatternParenLoc = ConPatArg 169 | deriving (Eq) 170 | 171 | instance Parens Pattern where 172 | type Loc Pattern = PatternParenLoc 173 | 174 | parenLoc (Var _) = [ConPatArg] 175 | parenLoc (In (ConPat _ [])) = [ConPatArg] 176 | parenLoc (In (ConPat _ _)) = [] 177 | 178 | parenRec (Var v) = 179 | name v 180 | parenRec (In (ConPat c [])) = c 181 | parenRec (In (ConPat c ps)) = 182 | c ++ " " ++ unwords (map (parenthesize (Just ConPatArg) . body) ps) -------------------------------------------------------------------------------- /src/Simple/Core/Type.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -- | The types of the simply typed lambda calculus w/ non-parametric user 15 | -- defined types (eg Bool, Nat). 16 | 17 | module Simple.Core.Type where 18 | 19 | import Utils.ABT 20 | import Utils.Pretty 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | -- | Types can be type constructors, functions, or meta-variables. 29 | -- Meta-variable types are used for type checking with unification. 30 | -- Variables are also not used in this setting, but we address them anyway. 31 | 32 | data TypeF r 33 | = TyCon String 34 | | Fun r r 35 | deriving (Eq,Functor,Foldable) 36 | 37 | 38 | type Type = ABT TypeF 39 | 40 | 41 | tyConH :: String -> Type 42 | tyConH c = In (TyCon c) 43 | 44 | funH :: Type -> Type -> Type 45 | funH a b = In (Fun (scope [] a) (scope [] b)) 46 | 47 | 48 | 49 | 50 | 51 | -- | There are two possible recursive locations within a type, so there are 52 | -- two 'TypeParenLoc's for the parenthesizer to use. 53 | 54 | data TypeParenLoc = FunLeft | FunRight 55 | deriving (Eq) 56 | 57 | 58 | -- | Everything can be de-parenthesized everywhere, except for functions. 59 | -- A function can only be de-parenthesized on the right of a function arrow. 60 | 61 | instance Parens Type where 62 | type Loc Type = TypeParenLoc 63 | 64 | parenLoc (Var _) = [FunLeft,FunRight] 65 | parenLoc (In (TyCon _)) = [FunLeft,FunRight] 66 | parenLoc (In (Fun _ _)) = [FunRight] 67 | 68 | parenRec (Var v) = name v 69 | parenRec (In (TyCon c)) = c 70 | parenRec (In (Fun a b)) = 71 | parenthesize (Just FunLeft) (instantiate0 a) 72 | ++ " -> " 73 | ++ parenthesize (Just FunRight) (instantiate0 b) -------------------------------------------------------------------------------- /src/Simple/Demo.sfp: -------------------------------------------------------------------------------- 1 | data Nat = Zero | Suc Nat end 2 | 3 | 4 | let plus : Nat -> Nat -> Nat 5 | = \x -> \y -> 6 | case x of 7 | | Zero -> y 8 | | Suc x' -> Suc (plus x' y) 9 | end 10 | end 11 | 12 | 13 | let plus' : Nat -> Nat -> Nat where 14 | | plus' Zero y = y 15 | | plus' (Suc x) y = Suc (plus' x y) 16 | end -------------------------------------------------------------------------------- /src/Simple/Monadic/Elaboration.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module defines how elaboration of programs is performed. 10 | 11 | module Simple.Monadic.Elaboration where 12 | 13 | import Utils.ABT 14 | import Utils.Elaborator 15 | import Utils.Vars 16 | import Simple.Core.ConSig 17 | import Simple.Core.Term 18 | import Simple.Core.Type 19 | import Simple.Core.Program 20 | import Simple.Monadic.Elaborator 21 | import Simple.Monadic.TypeChecking 22 | 23 | import Control.Monad.Except 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | -- | We can add a new defined value declaration given a name, term, and type. 33 | 34 | addDeclaration :: String -> Term -> Type -> Elaborator () 35 | addDeclaration n def ty = addElab definitions [(n,(def,ty))] 36 | 37 | 38 | -- | We can add a new type constructor by giving a name. 39 | 40 | addTypeConstructor :: String -> Elaborator () 41 | addTypeConstructor n = addElab (signature.typeConstructors) [n] 42 | 43 | 44 | -- | We can add a new data constructor by given a type constructor name, a 45 | -- name for the data constructor, and a list of arg types from which to build 46 | -- a constructor signature. 47 | 48 | addConstructor :: String -> ConSig -> Elaborator () 49 | addConstructor n consig = addElab (signature.dataConstructors) [(n,consig)] 50 | 51 | 52 | 53 | 54 | 55 | -- | Elaborating a term declaration takes one of two forms, depending on what 56 | -- kind of declaration is being elaborated. A definition of the form 57 | -- @let f : A = M end@ is elaborated directly, while a definition of the form 58 | -- @let f : A where f x y z = M end@ is first transformed into the former 59 | -- type of declaration, and then elaborated. 60 | -- 61 | -- This corresponds to the elaboration judgment @Σ ⊢ let x : A = M end def⇝ Δ@ 62 | -- which is defined as 63 | -- 64 | -- @ 65 | -- Δ # x A type x : A true ⊢ M ⇐ A true 66 | -- -------------------------------------------- 67 | -- Δ ⊢ let x : A = M end def⇝ Δ, x = M : A true 68 | -- @ 69 | -- 70 | -- where @Δ # x@ means that @x@ is not defined in @Δ@. 71 | 72 | elabTermDecl :: TermDeclaration -> Elaborator () 73 | elabTermDecl (TermDeclaration n ty def0) = 74 | do let def = freeToDefined (In . Defined) def0 75 | when' (typeInDefinitions n) 76 | $ throwError ("Term already defined: " ++ n) 77 | isType ty 78 | extendElab definitions [(n,(def,ty))] 79 | $ check def ty 80 | addDeclaration n def ty 81 | elabTermDecl (WhereDeclaration n ty preclauses) = 82 | case preclauses of 83 | [] -> throwError "Cannot create an empty let-where definition." 84 | [(ps,xs,b)] | all isVarPat ps 85 | -> elabTermDecl 86 | (TermDeclaration 87 | n 88 | ty 89 | (helperFold lamH xs b)) 90 | (ps0,_,_):_ 91 | -> let clauses = [ clauseH xs ps b 92 | | (ps,xs,b) <- preclauses 93 | ] 94 | xs0 = [ "x" ++ show i | i <- [0..length ps0-1] ] 95 | in elabTermDecl 96 | (TermDeclaration 97 | n 98 | ty 99 | (helperFold 100 | lamH 101 | xs0 102 | (caseH (map (Var . Free . FreeVar) xs0) clauses))) 103 | where 104 | isVarPat :: Pattern -> Bool 105 | isVarPat (Var _) = True 106 | isVarPat _ = False 107 | 108 | 109 | 110 | 111 | 112 | -- | Elaboration of a constructor in this variant is a relatively simple 113 | -- process. This corresponds to the elaboration judgment @Σ ⊢ c con⇝ Σ'@ which 114 | -- is defined as 115 | -- 116 | -- @ 117 | -- Σ # c Ai type B type 118 | -- ------------------------------ 119 | -- Σ ⊢ c con⇝ Σ, c : (A0,...,An)B 120 | -- @ 121 | -- 122 | -- where @Σ # c@ means that @c@ is not a data constructor in @Σ@. 123 | 124 | elabAlt :: String -> ConSig -> Elaborator () 125 | elabAlt n consig = 126 | do when' (typeInSignature n) 127 | $ throwError ("Constructor already declared: " ++ n) 128 | checkConSig consig 129 | addConstructor n consig 130 | 131 | 132 | 133 | 134 | 135 | -- | Elaboration of multiple constructors in a type declaration just chains 136 | -- together their effect on the signature: 137 | -- 138 | -- @ 139 | -- Σ ⊢ L0 con⇝ Σ0 Σ0 ⊢ L1 con⇝ Σ1 ... Σn-1 ⊢ Ln con⇝ Σn 140 | -- ---------------------------------------------------------- 141 | -- Σ ⊢ L0 | ... | Ln cons⇝ Σn 142 | -- @ 143 | -- 144 | -- which has the effect of accumulating data constructor signatures. 145 | 146 | elabAlts :: [(String, ConSig)] -> Elaborator () 147 | elabAlts = mapM_ (uncurry elabAlt) 148 | 149 | 150 | 151 | 152 | 153 | -- | Elaboration of a type constructor is similar to elaborating a data 154 | -- constructor, except it includes elaborations for the constructors as well. 155 | -- 156 | -- @ 157 | -- Σ # c Ai type Σ, c tycon ⊢ L0 | ... | Ln cons⇝ Σ' 158 | -- ----------------------------------------------------- 159 | -- Σ ⊢ data c where L0 | ... | L1 end tycon⇝ Σ' 160 | -- @ 161 | -- 162 | -- where here @Σ # c@ means that @c@ is not a type constructor in @Σ@. 163 | 164 | elabTypeDecl :: TypeDeclaration -> Elaborator () 165 | elabTypeDecl (TypeDeclaration tycon alts) = 166 | do when' (tyconExists tycon) 167 | $ throwError ("Type constructor already declared: " ++ tycon) 168 | addTypeConstructor tycon 169 | elabAlts alts 170 | 171 | 172 | 173 | 174 | 175 | -- Elaborating a whole program involves chaining together the elaborations of 176 | -- each kind of declaration. We can define it inductively as follows: 177 | -- 178 | -- @ 179 | -- ----------------------- 180 | -- Σ ; Δ ⊢ e prog⇝ Σ' ; Δ' 181 | -- 182 | -- Σ ⊢ data c = L0 | ... | L1 end tycon⇝ Σ' Σ' ⊢ P prog⇝ Σ'' 183 | -- --------------------------------------------------------------- 184 | -- Σ ⊢ data c = L0 | ... | L1 end ; P prog⇝ Σ'' 185 | -- 186 | -- Δ ⊢ let x : A = M end def⇝ Δ' Δ' ⊢ P prog⇝ Δ'' 187 | -- ------------------------------------------------ 188 | -- Δ ⊢ let x : A = M end ; P prog⇝ Δ'' 189 | -- @ 190 | 191 | elabProgram :: Program -> Elaborator () 192 | elabProgram (Program stmts0) = go stmts0 193 | where 194 | go :: [Statement] -> Elaborator () 195 | go [] = return () 196 | go (TyDecl td:stmts) = do elabTypeDecl td 197 | go stmts 198 | go (TmDecl td:stmts) = do elabTermDecl td 199 | go stmts -------------------------------------------------------------------------------- /src/Simple/Monadic/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -- This module defines the core types of a monadic elaborator. 12 | 13 | module Simple.Monadic.Elaborator where 14 | 15 | import Utils.Env 16 | import Utils.Vars 17 | import Simple.Core.ConSig 18 | import Simple.Core.Term 19 | import Simple.Core.Type 20 | 21 | import qualified Control.Lens as L 22 | import Control.Monad.State 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | -- | A signature is a collection of type constructors, and data constructors 31 | -- together with their constructor signatures. This is used during type 32 | -- checking and elaboration to define the underlying type theory. 33 | 34 | data Signature 35 | = Signature 36 | { _typeConstructors :: [String] 37 | , _dataConstructors :: [(String,ConSig)] 38 | } 39 | L.makeLenses ''Signature 40 | 41 | 42 | 43 | 44 | 45 | -- | A definition consists of a declared name together with its definition 46 | -- and its type. 47 | 48 | type Definitions = [(String,(Term,Type))] 49 | 50 | definitionsToEnvironment :: Definitions -> Env String Term 51 | definitionsToEnvironment defs = 52 | [ (x,m) | (x,(m,_)) <- defs ] 53 | 54 | 55 | 56 | 57 | 58 | -- | A context contains generated variables together with their display names, 59 | -- and their declared types. 60 | 61 | type Context = [(FreeVar,Type)] 62 | 63 | 64 | 65 | 66 | 67 | -- | The definition of the state to be carried by the type checking monad for 68 | -- this particular variant. We need only the bare minimum of a signature, 69 | -- some defined terms, and a typing context. 70 | 71 | data ElabState 72 | = ElabState 73 | { _signature :: Signature 74 | , _definitions :: Definitions 75 | , _context :: Context 76 | } 77 | L.makeLenses ''ElabState 78 | 79 | 80 | type Elaborator a = StateT ElabState (Either String) a 81 | 82 | 83 | type TypeChecker a = Elaborator a 84 | 85 | 86 | runElaborator :: Elaborator a 87 | -> Signature 88 | -> Definitions 89 | -> Context 90 | -> Either String (a,ElabState) 91 | runElaborator e sig defs ctx = 92 | runStateT e (ElabState sig defs ctx) 93 | 94 | 95 | runElaborator0 :: Elaborator a -> Either String (a,ElabState) 96 | runElaborator0 e = runElaborator e (Signature [] []) [] [] 97 | 98 | 99 | when' :: Elaborator a -> Elaborator () -> Elaborator () 100 | when' e1 e2 = do s <- get 101 | case runStateT e1 s of 102 | Left _ -> return () 103 | Right _ -> e2 -------------------------------------------------------------------------------- /src/Simple/Monadic/Equality.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module defines equality on LC terms. Since this variant doesn't use 10 | -- unification, all that's necessary is simple equality. 11 | 12 | module Simple.Monadic.Equality where 13 | 14 | import Simple.Core.Type 15 | 16 | import Data.Functor.Classes 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | instance Eq1 TypeF where 25 | eq1 (TyCon c) (TyCon c') = 26 | c == c' 27 | eq1 (Fun a b) (Fun a' b') = 28 | a == a' && b == b' 29 | eq1 _ _ = False -------------------------------------------------------------------------------- /src/Simple/Monadic/REPL.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | module Simple.Monadic.REPL where 7 | 8 | import Control.Monad.Reader (runReaderT) 9 | 10 | import Utils.ABT 11 | import Utils.Env 12 | import Utils.Eval 13 | import Utils.Pretty 14 | import Simple.Core.Evaluation () 15 | import Simple.Core.Parser 16 | import Simple.Core.Term 17 | import Simple.Monadic.Elaboration 18 | import Simple.Monadic.Elaborator 19 | import Simple.Monadic.TypeChecking 20 | 21 | import System.IO 22 | 23 | 24 | 25 | 26 | 27 | flushStr :: String -> IO () 28 | flushStr str = putStr str >> hFlush stdout 29 | 30 | readPrompt :: String -> IO String 31 | readPrompt prompt = flushStr prompt >> getLine 32 | 33 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 34 | until_ p prompt action = do 35 | result <- prompt 36 | if p result 37 | then return () 38 | else action result >> until_ p prompt action 39 | 40 | repl :: String -> IO () 41 | repl src0 = case loadProgram src0 of 42 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 43 | Right (sig,defs,ctx,env) 44 | -> do hSetBuffering stdin LineBuffering 45 | until_ (== ":quit") 46 | (readPrompt "$> ") 47 | (evalAndPrint sig defs ctx env) 48 | where 49 | loadProgram :: String -> Either String (Signature,Definitions,Context,Env String Term) 50 | loadProgram src = 51 | do prog <- parseProgram src 52 | (_,ElabState sig defs ctx) <- runElaborator0 (elabProgram prog) 53 | let env = definitionsToEnvironment defs 54 | return (sig,defs,ctx,env) 55 | 56 | loadTerm :: Signature -> Definitions -> Context -> Env String Term -> String -> Either String Term 57 | loadTerm sig defs ctx env src = 58 | do tm0 <- parseTerm src 59 | let tm = freeToDefined (In . Defined) tm0 60 | case runElaborator (infer tm) sig defs ctx of 61 | Left e -> Left e 62 | Right _ -> runReaderT (eval tm) env 63 | 64 | evalAndPrint :: Signature -> Definitions -> Context -> Env String Term -> String -> IO () 65 | evalAndPrint _ _ _ _ "" = return () 66 | evalAndPrint sig defs ctx env src = 67 | case loadTerm sig defs ctx env src of 68 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 69 | Right v -> flushStr (pretty v ++ "\n") 70 | 71 | replFile :: String -> IO () 72 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Simple/Unification/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -- This module defines the core types of a unification elaborator. 12 | 13 | module Simple.Unification.Elaborator where 14 | 15 | import Utils.Env 16 | import Utils.Unifier 17 | import Utils.Vars 18 | import Simple.Core.ConSig 19 | import Simple.Core.Term 20 | import Simple.Core.Type 21 | 22 | import qualified Control.Lens as L 23 | import Control.Monad.State 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | -- | A signature is a collection of type constructors, and data constructors 32 | -- together with their constructor signatures. This is used during type 33 | -- checking and elaboration to define the underlying type theory. 34 | 35 | data Signature 36 | = Signature 37 | { _typeConstructors :: [String] 38 | , _dataConstructors :: [(String,ConSig)] 39 | } 40 | L.makeLenses ''Signature 41 | 42 | 43 | 44 | 45 | 46 | -- | A definition consists of a declared name together with its definition 47 | -- and its type. 48 | 49 | type Definitions = [(String,(Term,Type))] 50 | 51 | definitionsToEnvironment :: Definitions -> Env String Term 52 | definitionsToEnvironment defs = 53 | [ (x,m) | (x,(m,_)) <- defs ] 54 | 55 | 56 | 57 | 58 | 59 | -- | A context contains generated variables together with their types. 60 | 61 | type Context = [(FreeVar,Type)] 62 | 63 | 64 | 65 | 66 | 67 | -- | The definition of the state to be carried by the type checking monad for 68 | -- this particular variant. We need only the bare minimum of a signature, 69 | -- some defined terms, and a typing context. 70 | 71 | data ElabState 72 | = ElabState 73 | { _signature :: Signature 74 | , _definitions :: Definitions 75 | , _context :: Context 76 | , _substitution :: Substitution TypeF 77 | , _nextMeta :: MetaVar 78 | } 79 | L.makeLenses ''ElabState 80 | 81 | 82 | type Elaborator = StateT ElabState (Either String) 83 | 84 | 85 | type TypeChecker = Elaborator 86 | 87 | 88 | runElaborator :: Elaborator a 89 | -> Signature 90 | -> Definitions 91 | -> Context 92 | -> Either String (a,ElabState) 93 | runElaborator e sig defs ctx = 94 | runStateT e (ElabState sig defs ctx [] (MetaVar 0)) 95 | 96 | 97 | runElaborator0 :: Elaborator a -> Either String (a,ElabState) 98 | runElaborator0 e = runElaborator e (Signature [] []) [] [] 99 | 100 | 101 | when' :: Elaborator a -> Elaborator () -> Elaborator () 102 | when' e1 e2 = do s <- get 103 | case runStateT e1 s of 104 | Left _ -> return () 105 | Right _ -> e2 -------------------------------------------------------------------------------- /src/Simple/Unification/REPL.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | module Simple.Unification.REPL where 7 | 8 | import Control.Monad.Reader (runReaderT) 9 | 10 | import Utils.ABT 11 | import Utils.Env 12 | import Utils.Eval 13 | import Utils.Pretty 14 | import Simple.Core.Evaluation () 15 | import Simple.Core.Parser 16 | import Simple.Core.Term 17 | import Simple.Unification.Elaboration 18 | import Simple.Unification.Elaborator 19 | import Simple.Unification.TypeChecking 20 | 21 | import System.IO 22 | 23 | 24 | 25 | 26 | 27 | flushStr :: String -> IO () 28 | flushStr str = putStr str >> hFlush stdout 29 | 30 | readPrompt :: String -> IO String 31 | readPrompt prompt = flushStr prompt >> getLine 32 | 33 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 34 | until_ p prompt action = do 35 | result <- prompt 36 | if p result 37 | then return () 38 | else action result >> until_ p prompt action 39 | 40 | repl :: String -> IO () 41 | repl src0 = case loadProgram src0 of 42 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 43 | Right (sig,defs,ctx,env) 44 | -> do hSetBuffering stdin LineBuffering 45 | until_ (== ":quit") 46 | (readPrompt "$> ") 47 | (evalAndPrint sig defs ctx env) 48 | where 49 | loadProgram :: String -> Either String (Signature,Definitions,Context,Env String Term) 50 | loadProgram src = 51 | do prog <- parseProgram src 52 | (_,ElabState sig defs ctx _ _) <- runElaborator0 (elabProgram prog) 53 | let env = definitionsToEnvironment defs 54 | return (sig,defs,ctx,env) 55 | 56 | loadTerm :: Signature -> Definitions -> Context -> Env String Term -> String -> Either String Term 57 | loadTerm sig defs ctx env src = 58 | do tm0 <- parseTerm src 59 | let tm = freeToDefined (In . Defined) tm0 60 | case runElaborator (infer tm) sig defs ctx of 61 | Left e -> Left e 62 | Right _ -> runReaderT (eval tm) env 63 | 64 | evalAndPrint :: Signature -> Definitions -> Context -> Env String Term -> String -> IO () 65 | evalAndPrint _ _ _ _ "" = return () 66 | evalAndPrint sig defs ctx env src = 67 | case loadTerm sig defs ctx env src of 68 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 69 | Right v -> flushStr (pretty v ++ "\n") 70 | 71 | replFile :: String -> IO () 72 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Simple/Unification/Unification.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | -- | This module defines unification of simple types. 14 | 15 | module Simple.Unification.Unification where 16 | 17 | import Utils.ABT 18 | import Utils.Pretty 19 | import Utils.Unifier 20 | import Simple.Core.Type 21 | import Simple.Unification.Elaborator 22 | 23 | import Control.Monad.Except 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | -- | Equating terms by trivial structural equations. 32 | 33 | instance MonadUnify TypeF Elaborator where 34 | equate (TyCon tycon1) (TyCon tycon2) = 35 | do unless (tycon1 == tycon2) 36 | $ throwError $ "Mismatching type constructors " 37 | ++ tycon1 ++ " and " ++ tycon2 38 | return [] 39 | equate (Fun a1 b1) (Fun a2 b2) = 40 | return [ Equation (instantiate0 a1) (instantiate0 a2) 41 | , Equation (instantiate0 b1) (instantiate0 b2) 42 | ] 43 | equate l r = 44 | throwError $ "Cannot unify " ++ pretty (In l) ++ " with " ++ pretty (In r) -------------------------------------------------------------------------------- /src/Utils/ABTExamples.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | {-# LANGUAGE DeriveFoldable #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | 6 | 7 | 8 | 9 | 10 | module Utils.ABTExamples where 11 | 12 | import Utils.ABT 13 | 14 | 15 | 16 | 17 | 18 | -- | A simple example LC type for testing the functionality of ABTs. 19 | 20 | data LC r 21 | = Defined String 22 | | Pair r r | Fst r | Snd r 23 | | Lam r | App r r 24 | deriving (Show,Functor,Foldable) 25 | 26 | pairH x y = In (Pair (scope [] x) (scope [] y)) 27 | fstH p = In (Fst (scope [] p)) 28 | sndH p = In (Snd (scope [] p)) 29 | lamH n b = In (Lam (scope [n] b)) 30 | appH f x = In (App (scope [] f) (scope [] x)) 31 | 32 | ex :: ABT LC 33 | ex = lamH "p" (pairH (sndH (Var (Free "p"))) (fstH (Var (Free "foo")))) -------------------------------------------------------------------------------- /src/Utils/Elaborator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -- | This module defines a number of tools for use with elaborators. 15 | 16 | module Utils.Elaborator where 17 | 18 | import Utils.Vars 19 | 20 | import Control.Lens 21 | import Control.Monad.State 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | type MonadElab s m = MonadState s m 30 | 31 | 32 | 33 | 34 | 35 | -- | 'getElab' is a mnemonic for looking up the value of a lens on state. 36 | 37 | getElab :: MonadState s m => Lens' s a -> m a 38 | getElab = use 39 | 40 | 41 | 42 | 43 | 44 | -- | 'putElab' is a mnemonic for replacing the value of a lens on state. 45 | 46 | putElab :: MonadState s m => Lens' s a -> a -> m () 47 | putElab = assign 48 | 49 | 50 | 51 | 52 | 53 | -- | Given a lens that focuses on a list, we can add new elements to the list. 54 | 55 | addElab :: MonadState s m => Lens' s [a] -> [a] -> m () 56 | addElab l xs = l %= (xs ++) 57 | 58 | 59 | 60 | 61 | 62 | -- | Given a lens that focuses on a list, we can temporarily add new elements 63 | -- to the list for some computation. 64 | 65 | extendElab :: MonadState s m => Lens' s [a] -> [a] -> m b -> m b 66 | extendElab l xs m = do oldXs <- getElab l 67 | addElab l xs 68 | v <- m 69 | putElab l oldXs 70 | return v 71 | 72 | 73 | 74 | 75 | 76 | -- | Given a lens that focuses on a numeric value, we can increment that value 77 | -- and get back the original. This is useful for name stores to generate 78 | -- globally unique names, for instance. 79 | 80 | nextElab :: (Num a, MonadState s m) => Lens' s a -> m a 81 | nextElab l = do i <- getElab l 82 | putElab l (i+1) 83 | return i 84 | 85 | 86 | 87 | 88 | 89 | -- | We can freshen variables relative to any context-like list. 90 | 91 | freshRelTo :: MonadState s m 92 | => [String] -> Lens' s [(FreeVar,a)] -> m [FreeVar] 93 | freshRelTo ns l = do ctx <- getElab l 94 | let oldNs = [ n' | (FreeVar n',_) <- ctx ] 95 | return $ map FreeVar (freshen oldNs ns) -------------------------------------------------------------------------------- /src/Utils/Env.hs: -------------------------------------------------------------------------------- 1 | module Utils.Env where 2 | 3 | type Env i a = [(i,a)] -------------------------------------------------------------------------------- /src/Utils/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | 5 | module Utils.Eval where 6 | 7 | import Control.Monad.Reader 8 | 9 | type Evaluator e = ReaderT e (Either String) 10 | 11 | environment :: Evaluator e e 12 | environment = ask 13 | 14 | class Eval e a where 15 | eval :: a -> Evaluator e a 16 | 17 | class ParamEval p e a | e a -> p where 18 | paramEval :: p -> a -> Evaluator e a -------------------------------------------------------------------------------- /src/Utils/Names.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -- | This module defines some general name constructs that replace raw string 10 | -- names in many variants. 11 | 12 | module Utils.Names where 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | -- | A local name is a name for an item that's been brought into scope usually 21 | -- via module importing. It can be either a bare name, or a dotted name, used 22 | -- for qualified imports. An absolute name is like a dotted local name only it 23 | -- uses the actual name of the module and the item, independent of renaming. 24 | 25 | data Name 26 | = BareLocal String 27 | | DottedLocal String String 28 | | Absolute String String 29 | deriving (Show,Eq) 30 | 31 | 32 | showName :: Name -> String 33 | showName (BareLocal n) = n 34 | showName (DottedLocal m n) = m ++ "." ++ n 35 | showName (Absolute m n) = "!" ++ m ++ "." ++ n -------------------------------------------------------------------------------- /src/Utils/Plicity.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | 4 | 5 | -- | A type that represents plicity, i.e. implicit and explicit. 6 | module Utils.Plicity where 7 | 8 | 9 | 10 | data Plicity = Expl | Impl 11 | deriving (Eq,Show) -------------------------------------------------------------------------------- /src/Utils/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | 8 | 9 | 10 | 11 | -- | This module defines the tools required to correctly define a pretty 12 | -- printer that can de-parenthesize expressions appropriately. Instead of 13 | -- using something like a fixity level, instead we can represent the problem 14 | -- as determining where to de-parenthesize an expression. For example, if 15 | -- function application is represented as adjacency, as in Haskell, then we 16 | -- can deparenthesize @(M N)@ in the function position of application, i.e. 17 | -- @(M N) P@ can become @M N P@, but not in the argument position, i.e. 18 | -- @M (N P)@ cannot become @M N P@ but instead must remain parenthesized. 19 | 20 | module Utils.Pretty where 21 | 22 | 23 | 24 | 25 | 26 | class Parens a where 27 | 28 | -- | @Loc a@ is the type of names for the recursive locations in @a@. 29 | type Loc a 30 | 31 | -- | 'parenLoc' maps each @a@ to a list of locations that permit it to 32 | -- be pretty printed without enclosing parentheses. 33 | parenLoc :: a -> [Loc a] 34 | 35 | -- | 'parenRec' pretty prints its argument without enclosing parentheses. 36 | parenRec :: a -> String 37 | 38 | 39 | type Pretty a = (Parens a, Eq (Loc a)) 40 | 41 | 42 | -- | The 'parenthesize' function pretty prints its argument, inserting parens 43 | -- appropriately, based on the location of the argument in the overall pretty 44 | -- printing context, given by the argument @l@. When @l = Nothing@, this 45 | -- indicates that the term is the root term, and isn't inside a recursive 46 | -- location, therefore requiring no parentheses. 47 | 48 | parenthesize :: Pretty a => Maybe (Loc a) -> a -> String 49 | parenthesize l x = 50 | let rec = parenRec x 51 | in case l of 52 | Nothing -> rec 53 | Just loc 54 | | loc `elem` parenLoc x -> rec 55 | | otherwise -> "(" ++ rec ++ ")" 56 | 57 | 58 | pretty :: Pretty a => a -> String 59 | pretty = parenthesize Nothing -------------------------------------------------------------------------------- /src/Utils/Vars.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | module Utils.Vars where 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | -- * Variable types 19 | 20 | 21 | 22 | -- A free variable is just a 'String' but we use a @newtype@ to prevent 23 | -- accidentally using it for the wrong things. 24 | 25 | newtype FreeVar = FreeVar String 26 | deriving (Eq,Show) 27 | 28 | 29 | 30 | -- A bound variable is just an 'Int' but we use a @newtype@ to prevent 31 | -- accidentally using it for the wrong things. 32 | 33 | newtype BoundVar = BoundVar Int 34 | deriving (Eq,Show) 35 | 36 | 37 | 38 | -- | A meta variable is just an 'Int' but we use a @newtype@ to prevent 39 | -- accidentally using it for the wrong things. 40 | 41 | newtype MetaVar = MetaVar Int 42 | deriving (Eq,Show,Num,Ord) 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | -- * Freshening names 51 | 52 | 53 | 54 | -- | We can freshen a set of names relative to some other names. This ensures 55 | -- that the freshened names are distinct from the specified names, and also 56 | -- distinct from one another. 57 | 58 | freshen :: [String] -> [String] -> [String] 59 | freshen others ns = reverse (go (reverse ns)) 60 | where 61 | go :: [String] -> [String] 62 | go [] = [] 63 | go (oldN:oldNs) = newN:newNs 64 | where 65 | newNs = go oldNs 66 | newN = freshenName (newNs ++ others) oldN 67 | 68 | 69 | -- | We can freshen a single name relative to some other set of names, 70 | -- ensuring that the new name is distinct from all the specified names. 71 | 72 | freshenName :: [String] -> String -> String 73 | freshenName others n 74 | | n == "_" = n 75 | | n `elem` others = freshenName others (n ++ "'") 76 | | otherwise = n --------------------------------------------------------------------------------