├── Setup.hs ├── src ├── Env.hs ├── Plicity.hs ├── Eval.hs ├── Simple │ ├── Demo.sfp │ ├── Core │ │ ├── Type.hs │ │ ├── Program.hs │ │ ├── Evaluation.hs │ │ ├── Abstraction.hs │ │ ├── Term.hs │ │ └── Parser.hs │ ├── Unification │ │ ├── REPL.hs │ │ └── Elaboration.hs │ └── Monadic │ │ ├── REPL.hs │ │ ├── Elaboration.hs │ │ └── TypeChecking.hs ├── Record │ ├── Demo.sfp │ ├── Core │ │ ├── ConSig.hs │ │ ├── Program.hs │ │ ├── Evaluation.hs │ │ └── Abstraction.hs │ └── Unification │ │ └── REPL.hs ├── Quasiquote │ ├── Demo.sfp │ ├── Core │ │ ├── ConSig.hs │ │ ├── Evaluation.hs │ │ └── Program.hs │ └── Unification │ │ └── REPL.hs ├── OpenDefs │ ├── Demo.sfp │ ├── Core │ │ ├── ConSig.hs │ │ ├── Evaluation.hs │ │ └── Program.hs │ └── Unification │ │ └── REPL.hs ├── Abs.hs ├── Parens.hs ├── Dependent │ ├── Core │ │ ├── ConSig.hs │ │ ├── Program.hs │ │ ├── Evaluation.hs │ │ ├── Term.hs │ │ └── Abstraction.hs │ ├── Demo.sfp │ ├── Monadic │ │ ├── REPL.hs │ │ └── Elaboration.hs │ └── Unification │ │ ├── REPL.hs │ │ └── Elaboration.hs ├── Modular │ ├── Core │ │ ├── ConSig.hs │ │ ├── Evaluation.hs │ │ ├── Program.hs │ │ ├── Abstraction.hs │ │ └── Term.hs │ ├── Demo.sfp │ └── Unification │ │ └── REPL.hs ├── DependentImplicit │ ├── Core │ │ ├── ConSig.hs │ │ ├── Program.hs │ │ ├── Evaluation.hs │ │ ├── Term.hs │ │ └── Abstraction.hs │ ├── Demo.sfp │ └── Unification │ │ ├── REPL.hs │ │ └── Elaboration.hs ├── Scope.hs ├── Poly │ ├── Demo.sfp │ ├── Core │ │ ├── Program.hs │ │ ├── Evaluation.hs │ │ ├── Type.hs │ │ ├── Term.hs │ │ ├── Abstraction.hs │ │ └── Parser.hs │ └── Unification │ │ ├── REPL.hs │ │ └── Elaboration.hs └── TypeChecker.hs ├── .gitignore ├── README.md └── SimpleFP.cabal /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/Env.hs: -------------------------------------------------------------------------------- 1 | module Env where 2 | 3 | type Environment i a = [(i,a)] -------------------------------------------------------------------------------- /src/Plicity.hs: -------------------------------------------------------------------------------- 1 | module Plicity where 2 | 3 | data Plicity = Expl | Impl 4 | deriving (Eq,Show) -------------------------------------------------------------------------------- /.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 | *# -------------------------------------------------------------------------------- /src/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | module Eval where 5 | 6 | import Control.Monad.Reader 7 | 8 | type Evaluator e = ReaderT e (Either String) 9 | 10 | environment :: Evaluator e e 11 | environment = ask 12 | 13 | class Eval e a where 14 | eval :: a -> Evaluator e a -------------------------------------------------------------------------------- /src/Simple/Demo.sfp: -------------------------------------------------------------------------------- 1 | data Nat = Zero | Suc Nat end 2 | 3 | let plus : Nat -> Nat -> Nat 4 | = \x -> \y -> 5 | case x of 6 | | Zero -> y 7 | | Suc x2 -> Suc (plus x2 y) 8 | end 9 | end 10 | 11 | let plus' : Nat -> Nat -> Nat where 12 | | plus' Zero y = y 13 | | plus' (Suc x) y = Suc (plus' x y) 14 | end -------------------------------------------------------------------------------- /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/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 = unquote f as f' in unquote x as x' in quote (f' x') 15 | end 16 | 17 | end -------------------------------------------------------------------------------- /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/Abs.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | 6 | module Abs where 7 | 8 | import Control.Monad.Reader 9 | 10 | import Env 11 | 12 | type Abstracted i e a = Reader (Environment i e) a 13 | 14 | class Abstract i e a where 15 | abstract :: a -> Abstracted i e a 16 | 17 | instance Abstract i e a => Abstract i e [a] where 18 | abstract = mapM abstract 19 | 20 | abstractOver :: Abstract i e a => [i] -> a -> [e] -> a 21 | abstractOver [] m _ = m 22 | abstractOver xs m vs = runReader (abstract m) (zip xs vs) -------------------------------------------------------------------------------- /src/Parens.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module Parens where 7 | 8 | class ParenLoc a where 9 | type Loc a 10 | parenLoc :: a -> [Loc a] 11 | 12 | class ParenRec a where 13 | parenRec :: a -> String 14 | 15 | parenthesize :: (ParenLoc a, Eq (Loc a), ParenRec a) => Maybe (Loc a) -> a -> String 16 | parenthesize l x 17 | = let rec = parenRec x 18 | in case l of 19 | Nothing 20 | -> rec 21 | Just loc | loc `elem` parenLoc x 22 | -> rec 23 | _ -> "(" ++ rec ++ ")" -------------------------------------------------------------------------------- /src/Dependent/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Dependent.Core.ConSig where 4 | 5 | import Scope 6 | 7 | data ConSig a = ConSigNil a | ConSigCons a (Scope a (ConSig a)) 8 | 9 | showConSig :: Show a => (String -> a) -> ConSig a -> String 10 | showConSig _ (ConSigNil a) 11 | = show a 12 | showConSig f (ConSigCons a sc) | length (names sc) == 1 13 | = "(" ++ unwords (names sc) ++ " : " ++ show a ++ ") " 14 | ++ showConSig f (instantiate sc (map f (names sc))) 15 | showConSig _ _ 16 | = error "ConSigs should have exactly one scope argument." 17 | 18 | conSigLength :: (String -> a) -> ConSig a -> Int 19 | conSigLength _ (ConSigNil _) = 0 20 | conSigLength f (ConSigCons _ sc) 21 | = 1 + conSigLength f (instantiate sc (map f (names sc))) 22 | 23 | type Signature a = [(String,ConSig a)] -------------------------------------------------------------------------------- /src/Simple/Core/Type.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Simple.Core.Type where 5 | 6 | import Parens 7 | 8 | 9 | 10 | -- Types 11 | 12 | data Type 13 | = TyCon String 14 | | Fun Type Type 15 | | Meta Int 16 | deriving (Eq) 17 | 18 | 19 | 20 | -- Show Instance 21 | 22 | data TypeParenLoc = FunLeft | FunRight 23 | deriving (Eq) 24 | 25 | instance ParenLoc Type where 26 | type Loc Type = TypeParenLoc 27 | parenLoc (TyCon _) = [FunLeft,FunRight] 28 | parenLoc (Fun _ _) = [FunRight] 29 | parenLoc (Meta _) = [FunLeft,FunRight] 30 | 31 | instance ParenRec Type where 32 | parenRec (TyCon c) = c 33 | parenRec (Fun a b) = parenthesize (Just FunLeft) a 34 | ++ " -> " 35 | ++ parenthesize (Just FunRight) b 36 | parenRec (Meta i) = "?" ++ show i 37 | 38 | instance Show Type where 39 | show t = parenthesize Nothing t -------------------------------------------------------------------------------- /src/Record/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Record.Core.ConSig where 4 | 5 | import Plicity 6 | import Scope 7 | 8 | data ConSig a = ConSigNil a | ConSigCons Plicity a (Scope a (ConSig a)) 9 | 10 | showConSig :: Show a => (String -> a) -> ConSig a -> String 11 | showConSig _ (ConSigNil a) 12 | = show a 13 | showConSig f (ConSigCons plic a sc) | length (names sc) == 1 14 | = let a0' = unwords (names sc) ++ " : " ++ show a 15 | a' = case plic of 16 | Expl -> "(" ++ a0' ++ ") " 17 | Impl -> "{" ++ a0' ++ "} " 18 | in a' ++ showConSig f (instantiate sc (map f (names sc))) 19 | showConSig _ _ 20 | = error "ConSigs should have exactly one scope argument." 21 | 22 | conSigLength :: (String -> a) -> ConSig a -> Int 23 | conSigLength _ (ConSigNil _) = 0 24 | conSigLength f (ConSigCons _ _ sc) 25 | = 1 + conSigLength f (instantiate sc (map f (names sc))) 26 | 27 | type Signature a = [((String,String),ConSig a)] -------------------------------------------------------------------------------- /src/Modular/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Modular.Core.ConSig where 4 | 5 | import Plicity 6 | import Scope 7 | 8 | data ConSig a = ConSigNil a | ConSigCons Plicity a (Scope a (ConSig a)) 9 | 10 | showConSig :: Show a => (String -> a) -> ConSig a -> String 11 | showConSig _ (ConSigNil a) 12 | = show a 13 | showConSig f (ConSigCons plic a sc) | length (names sc) == 1 14 | = let a0' = unwords (names sc) ++ " : " ++ show a 15 | a' = case plic of 16 | Expl -> "(" ++ a0' ++ ") " 17 | Impl -> "{" ++ a0' ++ "} " 18 | in a' ++ showConSig f (instantiate sc (map f (names sc))) 19 | showConSig _ _ 20 | = error "ConSigs should have exactly one scope argument." 21 | 22 | conSigLength :: (String -> a) -> ConSig a -> Int 23 | conSigLength _ (ConSigNil _) = 0 24 | conSigLength f (ConSigCons _ _ sc) 25 | = 1 + conSigLength f (instantiate sc (map f (names sc))) 26 | 27 | type Signature a = [((String,String),ConSig a)] -------------------------------------------------------------------------------- /src/OpenDefs/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module OpenDefs.Core.ConSig where 4 | 5 | import Plicity 6 | import Scope 7 | 8 | data ConSig a = ConSigNil a | ConSigCons Plicity a (Scope a (ConSig a)) 9 | 10 | showConSig :: Show a => (String -> a) -> ConSig a -> String 11 | showConSig _ (ConSigNil a) 12 | = show a 13 | showConSig f (ConSigCons plic a sc) | length (names sc) == 1 14 | = let a0' = unwords (names sc) ++ " : " ++ show a 15 | a' = case plic of 16 | Expl -> "(" ++ a0' ++ ") " 17 | Impl -> "{" ++ a0' ++ "} " 18 | in a' ++ showConSig f (instantiate sc (map f (names sc))) 19 | showConSig _ _ 20 | = error "ConSigs should have exactly one scope argument." 21 | 22 | conSigLength :: (String -> a) -> ConSig a -> Int 23 | conSigLength _ (ConSigNil _) = 0 24 | conSigLength f (ConSigCons _ _ sc) 25 | = 1 + conSigLength f (instantiate sc (map f (names sc))) 26 | 27 | type Signature a = [((String,String),ConSig a)] -------------------------------------------------------------------------------- /src/Quasiquote/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Quasiquote.Core.ConSig where 4 | 5 | import Plicity 6 | import Scope 7 | 8 | data ConSig a = ConSigNil a | ConSigCons Plicity a (Scope a (ConSig a)) 9 | 10 | showConSig :: Show a => (String -> a) -> ConSig a -> String 11 | showConSig _ (ConSigNil a) 12 | = show a 13 | showConSig f (ConSigCons plic a sc) | length (names sc) == 1 14 | = let a0' = unwords (names sc) ++ " : " ++ show a 15 | a' = case plic of 16 | Expl -> "(" ++ a0' ++ ") " 17 | Impl -> "{" ++ a0' ++ "} " 18 | in a' ++ showConSig f (instantiate sc (map f (names sc))) 19 | showConSig _ _ 20 | = error "ConSigs should have exactly one scope argument." 21 | 22 | conSigLength :: (String -> a) -> ConSig a -> Int 23 | conSigLength _ (ConSigNil _) = 0 24 | conSigLength f (ConSigCons _ _ sc) 25 | = 1 + conSigLength f (instantiate sc (map f (names sc))) 26 | 27 | type Signature a = [((String,String),ConSig a)] -------------------------------------------------------------------------------- /src/DependentImplicit/Core/ConSig.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module DependentImplicit.Core.ConSig where 4 | 5 | import Plicity 6 | import Scope 7 | 8 | data ConSig a = ConSigNil a | ConSigCons Plicity a (Scope a (ConSig a)) 9 | 10 | showConSig :: Show a => (String -> a) -> ConSig a -> String 11 | showConSig _ (ConSigNil a) 12 | = show a 13 | showConSig f (ConSigCons plic a sc) | length (names sc) == 1 14 | = let a0' = unwords (names sc) ++ " : " ++ show a 15 | a' = case plic of 16 | Expl -> "(" ++ a0' ++ ") " 17 | Impl -> "{" ++ a0' ++ "} " 18 | in a' ++ showConSig f (instantiate sc (map f (names sc))) 19 | showConSig _ _ 20 | = error "ConSigs should have exactly one scope argument." 21 | 22 | conSigLength :: (String -> a) -> ConSig a -> Int 23 | conSigLength _ (ConSigNil _) = 0 24 | conSigLength f (ConSigCons _ _ sc) 25 | = 1 + conSigLength f (instantiate sc (map f (names sc))) 26 | 27 | type Signature a = [(String,ConSig a)] -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # SimpleFP 2 | A series of implementations of a simple functional programming language, progressing from a very basic variant with no parametric types or polymorphism, through a parametric and polymorphic language, to a dependently typed language with various levels of user-friendliness. 3 | 4 | The `Core` modules define the language proper. The `Monadic` modules use a monadic style for managing information. The `Unification` modules are a variant of the `Monadic` modules that use metavariables and unification instead of equality tests to allow a wider ranger of programs, especially where implicit arguments are present, as in the polymorphic variant. 5 | 6 | You can try this out in cabal by doing `cabal repl` to load it up, then 7 | 8 | Simple.Monadic.REPL.replFile "src/Demos.sfp" 9 | 10 | This starts a REPL in the SimpleFP language, by loading and compiling the specified file (here just Demos.sfp). You can then test out the functions: 11 | 12 | $> even Zero 13 | True 14 | 15 | $> odd (Suc (Suc Zero)) 16 | False -------------------------------------------------------------------------------- /src/Scope.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Scope where 4 | 5 | import Control.Monad.Reader 6 | 7 | import Abs 8 | 9 | data Scope s a 10 | = Scope { names :: [String], instantiate :: [s] -> a } 11 | 12 | abstractScope :: Abstract i e a => Scope s a -> Abstracted i e (Scope s a) 13 | abstractScope (Scope ns f) 14 | = reader $ \e -> 15 | Scope ns $ \vs' -> runReader (abstract (f vs')) e 16 | 17 | scope :: Abstract String s a => [String] -> a -> Scope s a 18 | scope xs m = Scope xs (abstractOver xs m) 19 | 20 | scope2 :: Abstract String s a => [String] -> [String] -> a -> Scope s a 21 | scope2 xs xs' m = Scope xs (abstractOver xs' m) 22 | 23 | descope :: (String -> s) -> Scope s a -> a 24 | descope f sc = instantiate sc (map f (names sc)) 25 | 26 | instance Functor (Scope s) where 27 | fmap f (Scope ns b) = Scope ns (f . b) 28 | 29 | helperFold :: (a -> b -> b) -> [a] -> b -> b 30 | helperFold c xs n = foldr c n xs 31 | 32 | isVar :: String -> Bool 33 | isVar "_" = False 34 | isVar ('$':_) = False 35 | isVar _ = True 36 | 37 | removeByDummies :: [String] -> [a] -> [a] 38 | removeByDummies ns xs = [ x | (n,x) <- zip ns xs, isVar n ] -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /SimpleFP.cabal: -------------------------------------------------------------------------------- 1 | -- Initial SimpleFP.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: SimpleFP 5 | version: 0.1.0.0 6 | synopsis: A tutorial on implementing a functional programming language. 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: 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 | 30 | -- other-modules: 31 | -- other-extensions: 32 | build-depends: base, 33 | containers, 34 | mtl, 35 | parsec, 36 | transformers 37 | hs-source-dirs: src 38 | default-language: Haskell2010 -------------------------------------------------------------------------------- /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 | 19 | end 20 | 21 | 22 | module Vec1 opening Nat where 23 | 24 | data Vec (a : Type) (n : Nat) where 25 | | Nil {a : Type} : Vec a Zero 26 | | Cons {a : Type} {n : Nat} (x : a) (xs : Vec a n) : Vec a (Suc n) 27 | end 28 | 29 | end 30 | 31 | 32 | module Vec2 opening Nat as N where 33 | 34 | data Vec (a : Type) (n : N.Nat) where 35 | | Nil {a : Type} : Vec a N.Zero 36 | | Cons {a : Type} {n : N.Nat} (x : a) (xs : Vec a n) : Vec a (N.Suc n) 37 | end 38 | 39 | end 40 | 41 | 42 | module Vec3 43 | opening 44 | | Nat renaming (Zero to Z, Suc to S) 45 | where 46 | 47 | data Vec (a : Type) (n : Nat) where 48 | | Nil {a : Type} : Vec a Z 49 | | Cons {a : Type} {n : Nat} (x : a) (xs : Vec a n) : Vec a (S n) 50 | end 51 | 52 | end 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/Poly/Demo.sfp: -------------------------------------------------------------------------------- 1 | data Bool = True | False end 2 | 3 | let not : Bool -> Bool 4 | = \b -> case b of 5 | | True -> False 6 | | False -> True 7 | end 8 | end 9 | 10 | data Nat = Zero | Suc Nat end 11 | 12 | let even : Nat -> Bool 13 | = \n -> case n of 14 | | Zero -> True 15 | | Suc Zero -> False 16 | | Suc (Suc n) -> even n 17 | end 18 | end 19 | 20 | let plus : Nat -> Nat -> Nat 21 | = \x -> \y -> 22 | case x of 23 | | Zero -> y 24 | | Suc x2 -> Suc (plus x2 y) 25 | end 26 | end 27 | 28 | let mul : Nat -> Nat -> Nat 29 | = \x -> \y -> 30 | case x of 31 | | Zero -> Zero 32 | | Suc n -> plus y (mul n y) 33 | end 34 | end 35 | 36 | let id : forall a. a -> a 37 | = \x -> x 38 | end 39 | 40 | let const : forall a. forall b. a -> b -> a 41 | = \x -> \y -> x 42 | end 43 | 44 | data Unit = Unit end 45 | 46 | data Delay a = Delay (Unit -> a) end 47 | 48 | let force : forall a. Delay a -> a 49 | = \thunk -> case thunk of 50 | | Delay f -> f Unit 51 | end 52 | end 53 | 54 | let if : forall a. Bool -> Delay a -> Delay a -> a 55 | = \b -> \t -> \f -> 56 | case b of 57 | | True -> force t 58 | | False -> force f 59 | end 60 | end 61 | 62 | data List a = Nil | Cons a (List a) end 63 | 64 | let map : forall a. forall b. (a -> b) -> List a -> List b 65 | = \f -> \l -> 66 | case l of 67 | | Nil -> Nil 68 | | Cons x xs -> Cons (f x) (map f xs) 69 | end 70 | end 71 | 72 | let compose : forall a. forall b. forall c. (b -> c) -> (a -> b) -> a -> c 73 | = \f -> \g -> \x -> f (g x) 74 | end -------------------------------------------------------------------------------- /src/Simple/Core/Program.hs: -------------------------------------------------------------------------------- 1 | module Simple.Core.Program where 2 | 3 | import Data.List (intercalate) 4 | 5 | import Parens 6 | import Simple.Core.Term 7 | import Simple.Core.Type 8 | 9 | 10 | 11 | -- Term Declarations 12 | 13 | data TermDeclaration 14 | = TermDeclaration String Type Term 15 | | WhereDeclaration String Type [([Pattern],[String],Term)] 16 | 17 | instance Show TermDeclaration where 18 | show (TermDeclaration n ty def) 19 | = "let " ++ n ++ " : " ++ show ty ++ " = " ++ show def ++ " end" 20 | show (WhereDeclaration n ty preclauses) 21 | = "let " ++ n ++ " : " ++ show ty ++ " where " 22 | ++ intercalate " | " (map showPreclause preclauses) 23 | where 24 | showPreclause :: ([Pattern],[String],Term) -> String 25 | showPreclause (ps,_,b) 26 | = intercalate " || " (map (parenthesize Nothing) ps) ++ " -> " ++ show b 27 | 28 | 29 | 30 | -- Type Declarations 31 | 32 | data TypeDeclaration 33 | = TypeDeclaration String [(String,[Type])] 34 | 35 | instance Show TypeDeclaration where 36 | show (TypeDeclaration tycon []) 37 | = "data " ++ tycon ++ " end" 38 | show (TypeDeclaration tycon alts) 39 | = "data " ++ tycon ++ " = " 40 | ++ intercalate " | " [ showAlt c as | (c,as) <- alts ] 41 | ++ " end" 42 | where 43 | showAlt :: String -> [Type] -> String 44 | showAlt c [] = c 45 | showAlt c as = c ++ " " ++ intercalate " " (map show as) 46 | 47 | 48 | 49 | -- Programs 50 | 51 | data Statement 52 | = TyDecl TypeDeclaration 53 | | TmDecl TermDeclaration 54 | 55 | instance Show Statement where 56 | show (TyDecl td) = show td 57 | show (TmDecl td) = show td 58 | 59 | 60 | newtype Program = Program [Statement] 61 | 62 | instance Show Program where 63 | show (Program stmts) = intercalate "\n\n" (map show stmts) -------------------------------------------------------------------------------- /src/Dependent/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Dependent.Core.Program where 4 | 5 | import Data.List (intercalate) 6 | 7 | import Parens 8 | import Dependent.Core.ConSig 9 | import Dependent.Core.Term 10 | 11 | 12 | 13 | -- Term Declarations 14 | 15 | data TermDeclaration 16 | = TermDeclaration String Term Term 17 | | WhereDeclaration String Term [([Pattern],[String],Term)] 18 | 19 | instance Show TermDeclaration where 20 | show (TermDeclaration n ty def) 21 | = "let " ++ n ++ " : " ++ show ty ++ " = " ++ show def ++ " end" 22 | show (WhereDeclaration n ty preclauses) 23 | = "let " ++ n ++ " : " ++ show ty ++ " where " 24 | ++ intercalate " | " (map showPreclause preclauses) 25 | where 26 | showPreclause :: ([Pattern],[String],Term) -> String 27 | showPreclause (ps,_,b) 28 | = intercalate " || " (map (parenthesize Nothing) ps) ++ " -> " ++ show b 29 | 30 | 31 | 32 | -- Type Declarations 33 | 34 | data TypeDeclaration 35 | = TypeDeclaration String [DeclArg] [(String,ConSig Term)] 36 | 37 | instance Show TypeDeclaration where 38 | show (TypeDeclaration tycon tyargs []) 39 | = "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 40 | show (TypeDeclaration tycon tyargs alts) 41 | = "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " where" 42 | ++ concat [ "\n" ++ c ++ " : " ++ showConSig (Var . Name) sig | (c,sig) <- alts ] 43 | ++ "\nend" 44 | 45 | 46 | 47 | -- Programs 48 | 49 | data Statement 50 | = TyDecl TypeDeclaration 51 | | TmDecl TermDeclaration 52 | 53 | instance Show Statement where 54 | show (TyDecl td) = show td 55 | show (TmDecl td) = show td 56 | 57 | 58 | newtype Program = Program [Statement] 59 | 60 | instance Show Program where 61 | show (Program stmts) = intercalate "\n\n" (map show stmts) -------------------------------------------------------------------------------- /src/Poly/Core/Program.hs: -------------------------------------------------------------------------------- 1 | module Poly.Core.Program where 2 | 3 | import Data.List (intercalate) 4 | 5 | import Parens 6 | import Poly.Core.Term 7 | import Poly.Core.Type 8 | 9 | 10 | 11 | -- Term Declarations 12 | 13 | data TermDeclaration 14 | = TermDeclaration String Type Term 15 | | WhereDeclaration String Type [([Pattern],[String],Term)] 16 | 17 | instance Show TermDeclaration where 18 | show (TermDeclaration n ty def) 19 | = "let " ++ n ++ " : " ++ show ty ++ " = " ++ show def ++ " end" 20 | show (WhereDeclaration n ty preclauses) 21 | = "let " ++ n ++ " : " ++ show ty ++ " where " 22 | ++ intercalate " | " (map showPreclause preclauses) 23 | where 24 | showPreclause :: ([Pattern],[String],Term) -> String 25 | showPreclause (ps,_,b) 26 | = intercalate " || " (map (parenthesize Nothing) ps) ++ " -> " ++ show b 27 | 28 | 29 | 30 | -- Type Declarations 31 | 32 | data TypeDeclaration 33 | = TypeDeclaration String [String] [(String,[Type])] 34 | 35 | instance Show TypeDeclaration where 36 | show (TypeDeclaration tycon params []) 37 | = "data " ++ tycon ++ concat (map (' ':) params) ++ " end" 38 | show (TypeDeclaration tycon params alts) 39 | = "data " ++ tycon ++ concat (map (' ':) params) ++ " = " 40 | ++ intercalate " | " [ showAlt c as | (c,as) <- alts ] 41 | ++ " end" 42 | where 43 | showAlt :: String -> [Type] -> String 44 | showAlt c [] = c 45 | showAlt c as = c ++ " " ++ intercalate " " (map show as) 46 | 47 | 48 | 49 | -- Programs 50 | 51 | data Statement 52 | = TyDecl TypeDeclaration 53 | | TmDecl TermDeclaration 54 | 55 | instance Show Statement where 56 | show (TyDecl td) = show td 57 | show (TmDecl td) = show td 58 | 59 | 60 | newtype Program = Program [Statement] 61 | 62 | instance Show Program where 63 | show (Program stmts) = intercalate "\n\n" (map show stmts) -------------------------------------------------------------------------------- /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 | 24 | data Nat where 25 | | Zero : Nat 26 | | Suc (n : Nat) : Nat 27 | end 28 | 29 | let plusOne : (n : Nat) -> Nat 30 | = \n -> Suc n 31 | end 32 | 33 | let ex2 : Inv plusOne (Suc Zero) 34 | = InvEl Zero 35 | end 36 | 37 | 38 | let natInd : (p : (n : Nat) -> Type) -> (z : p Zero) -> (s : (n : Nat) -> (r : p n) -> p (Suc n)) -> (n : Nat) -> p n 39 | = \p -> \z -> \s -> \n -> 40 | case n 41 | motive (n' : Nat) || p n' 42 | of 43 | | Zero -> z 44 | | Suc n' -> s n' (natInd p z s n') 45 | end 46 | end 47 | 48 | 49 | data Vec (a : Type) (n : Nat) where 50 | | Nil {a : Type} : Vec a Zero 51 | | Cons {a : Type} {n : Nat} (x : a) (xs : Vec a n) : Vec a (Suc n) 52 | end 53 | 54 | 55 | let vapp : {a : Type} -> {b : Type} -> {n : Nat} -> (fs : Vec ((x : a) -> b) n) -> (xs : Vec a n) -> Vec b n 56 | = \{a} -> \{b} -> \{n} -> \fs -> \xs -> 57 | case n || fs || xs 58 | motive (n' : Nat) || (fs' : Vec ((x : a) -> b) n') || (xs' : Vec a n') || Vec b n' 59 | of 60 | | Zero || Nil || Nil -> Nil 61 | | Suc n' || Cons f fs' || Cons x xs' -> Cons (f x) (vapp fs' xs') 62 | end 63 | end 64 | 65 | 66 | let vec : {a : Type} -> {n : Nat} -> (x : a) -> Vec a n 67 | = \{a} -> \{n} -> \x -> 68 | case n 69 | motive (n' : Nat) || Vec a n' 70 | of 71 | | Zero -> Nil 72 | | Suc n' -> Cons x (vec x) 73 | end 74 | end 75 | 76 | let ex3 : Vec Bool (Suc (Suc (Suc Zero))) 77 | = vec True 78 | end -------------------------------------------------------------------------------- /src/Poly/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module Poly.Core.Evaluation where 7 | 8 | import Control.Monad.Except 9 | 10 | import Env 11 | import Eval 12 | import Scope 13 | import Poly.Core.Term 14 | 15 | 16 | -- Pattern Matching 17 | 18 | match :: Pattern -> Term -> Maybe [Term] 19 | match (VarPat _) v = Just [v] 20 | match (ConPat c ps) (Con c' as) 21 | | c == c' && length ps == length as 22 | = fmap concat (zipWithM match ps as) 23 | match _ _ = Nothing 24 | 25 | matchTerms :: [Pattern] -> [Term] -> Maybe [Term] 26 | matchTerms ps zs = fmap concat (zipWithM match ps zs) 27 | 28 | matchClauses :: [Clause] -> [Term] -> Maybe Term 29 | matchClauses [] _ 30 | = Nothing 31 | matchClauses (Clause psc sc:cs) vs 32 | = case matchTerms (descope Name psc) vs of 33 | Nothing -> matchClauses cs vs 34 | Just xs -> Just (instantiate sc (removeByDummies (names psc) xs)) 35 | 36 | 37 | 38 | -- Standard Eager Evaluation 39 | 40 | instance Eval (Environment String Term) Term where 41 | eval (Var (Name x)) 42 | = do env <- environment 43 | case lookup x env of 44 | Nothing -> throwError $ "Unknown constant/defined term: " ++ x 45 | Just m -> return m 46 | eval (Var (Generated x i)) 47 | = return $ Var (Generated x i) 48 | eval (Ann m _) 49 | = eval m 50 | eval (Lam sc) 51 | = return $ Lam sc 52 | eval (App f a) 53 | = do ef <- eval f 54 | ea <- eval a 55 | case ef of 56 | Lam sc -> eval (instantiate sc [ea]) 57 | _ -> return $ App ef ea 58 | eval (Con c as) 59 | = do eas <- mapM eval as 60 | return $ Con c eas 61 | eval (Case ms cs) 62 | = do ems <- mapM eval ms 63 | case matchClauses cs ems of 64 | Nothing -> throwError $ "Incomplete pattern match: " ++ show (Case ms cs) 65 | Just b -> eval b -------------------------------------------------------------------------------- /src/Simple/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module Simple.Core.Evaluation where 7 | 8 | import Control.Monad.Except 9 | 10 | import Env 11 | import Eval 12 | import Scope 13 | import Simple.Core.Term 14 | 15 | 16 | -- Pattern Matching 17 | 18 | match :: Pattern -> Term -> Maybe [Term] 19 | match (VarPat _) v = Just [v] 20 | match (ConPat c ps) (Con c' as) 21 | | c == c' && length ps == length as 22 | = fmap concat (zipWithM match ps as) 23 | match _ _ = Nothing 24 | 25 | matchTerms :: [Pattern] -> [Term] -> Maybe [Term] 26 | matchTerms ps zs = fmap concat (zipWithM match ps zs) 27 | 28 | matchClauses :: [Clause] -> [Term] -> Maybe Term 29 | matchClauses [] _ 30 | = Nothing 31 | matchClauses (Clause psc sc:cs) vs 32 | = case matchTerms (descope Name psc) vs of 33 | Nothing -> matchClauses cs vs 34 | Just xs -> Just (instantiate sc (removeByDummies (names psc) xs)) 35 | 36 | 37 | 38 | -- Standard Eager Evaluation 39 | 40 | instance Eval (Environment String Term) Term where 41 | eval (Var (Name x)) 42 | = do env <- environment 43 | case lookup x env of 44 | Nothing -> throwError $ "Unknown constant/defined term: " ++ x 45 | Just m -> return m 46 | eval (Var (Generated x i)) 47 | = return $ Var (Generated x i) 48 | eval (Ann m _) 49 | = eval m 50 | eval (Lam sc) 51 | = return $ Lam sc 52 | eval (App f a) 53 | = do ef <- eval f 54 | ea <- eval a 55 | case ef of 56 | Lam sc -> eval (instantiate sc [ea]) 57 | _ -> return $ App ef ea 58 | eval (Con c as) 59 | = do eas <- mapM eval as 60 | return $ Con c eas 61 | eval (Case ms cs) 62 | = do ems <- mapM eval ms 63 | case matchClauses cs ems of 64 | Nothing -> throwError $ "Incomplete pattern match: " ++ show (Case ms cs) 65 | Just b -> eval b -------------------------------------------------------------------------------- /src/Poly/Core/Type.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | 7 | module Poly.Core.Type where 8 | 9 | import Data.List (intercalate) 10 | 11 | import Parens 12 | import Scope 13 | 14 | 15 | 16 | -- Types 17 | 18 | data TyVariable 19 | = TyName String 20 | | TyGenerated String Int 21 | 22 | instance Eq TyVariable where 23 | TyName x == TyName y = x == y 24 | TyGenerated _ i == TyGenerated _ j = i == j 25 | _ == _ = False 26 | 27 | data Type 28 | = Meta Int 29 | | TyCon String [Type] 30 | | Fun Type Type 31 | | TyVar TyVariable 32 | | Forall (Scope Type Type) 33 | 34 | 35 | 36 | -- Show Instance 37 | 38 | instance Show TyVariable where 39 | show (TyName x) = x 40 | show (TyGenerated x _) = x 41 | 42 | data TypeParenLoc = TyConArg | FunLeft | FunRight | ForallBody 43 | deriving (Eq) 44 | 45 | instance ParenLoc Type where 46 | type Loc Type = TypeParenLoc 47 | parenLoc (Meta _) = [TyConArg,FunLeft,FunRight,ForallBody] 48 | parenLoc (TyCon _ []) = [TyConArg,FunLeft,FunRight,ForallBody] 49 | parenLoc (TyCon _ _) = [FunRight,ForallBody] 50 | parenLoc (Fun _ _) = [FunRight,ForallBody] 51 | parenLoc (TyVar _) = [TyConArg,FunLeft,FunRight,ForallBody] 52 | parenLoc (Forall _) = [FunRight,ForallBody] 53 | 54 | instance ParenRec Type where 55 | parenRec (Meta i) 56 | = "?" ++ show i 57 | parenRec (TyCon n []) 58 | = n 59 | parenRec (TyCon n as) 60 | = n ++ " " ++ intercalate " " (map (parenthesize (Just TyConArg)) as) 61 | parenRec (Fun a b) 62 | = parenthesize (Just FunLeft) a 63 | ++ " -> " 64 | ++ parenthesize (Just FunRight) b 65 | parenRec (TyVar n) 66 | = show n 67 | parenRec (Forall sc) 68 | = "forall " ++ unwords (names sc) ++ ". " 69 | ++ parenthesize (Just ForallBody) 70 | (instantiate sc [ TyVar (TyName x) | x <- names sc ]) 71 | 72 | instance Show Type where 73 | show t = parenthesize Nothing t -------------------------------------------------------------------------------- /src/DependentImplicit/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module DependentImplicit.Core.Program where 4 | 5 | import Data.List (intercalate) 6 | 7 | import Parens 8 | import Plicity 9 | import DependentImplicit.Core.ConSig 10 | import DependentImplicit.Core.Term 11 | 12 | 13 | 14 | -- Term Declarations 15 | 16 | data TermDeclaration 17 | = TermDeclaration String Term Term 18 | | WhereDeclaration String Term [([Plicity],([Pattern],[String],Term))] 19 | 20 | instance Show TermDeclaration where 21 | show (TermDeclaration n ty def) 22 | = "let " ++ n ++ " : " ++ show ty ++ " = " ++ show def ++ " end" 23 | show (WhereDeclaration n ty preclauses) 24 | = "let " ++ n ++ " : " ++ show ty ++ " where " 25 | ++ intercalate " | " (map showPreclause preclauses) 26 | where 27 | showPreclause :: ([Plicity],([Pattern],[String],Term)) -> String 28 | showPreclause (plics,(ps,_,b)) 29 | = intercalate " || " (map showPattern (zip plics ps)) ++ " -> " ++ show b 30 | 31 | showPattern :: (Plicity,Pattern) -> String 32 | showPattern (Expl,p) = parenthesize (Just ExplConPatArg) p 33 | showPattern (Impl,p) = parenthesize (Just ImplConPatArg) p 34 | 35 | 36 | 37 | -- Type Declarations 38 | 39 | data TypeDeclaration 40 | = TypeDeclaration String [DeclArg] [(String,ConSig Term)] 41 | 42 | instance Show TypeDeclaration where 43 | show (TypeDeclaration tycon tyargs []) 44 | = "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 45 | show (TypeDeclaration tycon tyargs alts) 46 | = "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " where" 47 | ++ concat [ "\n" ++ c ++ " : " ++ showConSig (Var . Name) sig | (c,sig) <- alts ] 48 | ++ "\nend" 49 | 50 | 51 | 52 | -- Programs 53 | 54 | data Statement 55 | = TyDecl TypeDeclaration 56 | | TmDecl TermDeclaration 57 | 58 | instance Show Statement where 59 | show (TyDecl td) = show td 60 | show (TmDecl td) = show td 61 | 62 | 63 | newtype Program = Program [Statement] 64 | 65 | instance Show Program where 66 | show (Program stmts) = intercalate "\n\n" (map show stmts) -------------------------------------------------------------------------------- /src/Poly/Unification/REPL.hs: -------------------------------------------------------------------------------- 1 | module Poly.Unification.REPL where 2 | 3 | import Control.Monad.Reader 4 | import System.IO 5 | 6 | import Env 7 | import Eval 8 | import Poly.Unification.Elaboration 9 | import Poly.Unification.TypeChecking 10 | import Poly.Core.Evaluation 11 | import Poly.Core.Parser 12 | import Poly.Core.Term 13 | 14 | flushStr :: String -> IO () 15 | flushStr str = putStr str >> hFlush stdout 16 | 17 | readPrompt :: String -> IO String 18 | readPrompt prompt = flushStr prompt >> getLine 19 | 20 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 21 | until_ p prompt action = do 22 | result <- prompt 23 | if p result 24 | then return () 25 | else action result >> until_ p prompt action 26 | 27 | repl :: String -> IO () 28 | repl src = case loadProgram src of 29 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 30 | Right (sig,defs,ctx,i,env) 31 | -> do hSetBuffering stdin LineBuffering 32 | until_ (== ":quit") 33 | (readPrompt "$> ") 34 | (evalAndPrint sig defs ctx i env) 35 | where 36 | loadProgram :: String -> Either String (Signature,Definitions,Context,Int,Environment String Term) 37 | loadProgram src 38 | = do prog <- parseProgram src 39 | ElabState sig defs ctx i <- runElaborator (elabProgram prog) 40 | let env = [ (x,m) | (x,m,_) <- defs ] 41 | return (sig,defs,ctx,i,env) 42 | 43 | loadTerm :: Signature -> Definitions -> Context -> Int -> Environment String Term -> String -> Either String Term 44 | loadTerm sig defs ctx i env src 45 | = do tm <- parseTerm src 46 | case runTypeChecker (infer tm) sig defs ctx i of 47 | Left e -> Left e 48 | Right _ -> runReaderT (eval tm) env 49 | 50 | evalAndPrint :: Signature -> Definitions -> Context -> Int -> Environment String Term -> String -> IO () 51 | evalAndPrint _ _ _ _ _ "" = return () 52 | evalAndPrint sig defs ctx i env src 53 | = case loadTerm sig defs ctx i env src of 54 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 55 | Right v -> flushStr (show v ++ "\n") 56 | 57 | replFile :: String -> IO () 58 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Simple/Unification/REPL.hs: -------------------------------------------------------------------------------- 1 | module Simple.Unification.REPL where 2 | 3 | import Control.Monad.Reader 4 | import System.IO 5 | 6 | import Env 7 | import Eval 8 | import Simple.Unification.Elaboration 9 | import Simple.Unification.TypeChecking 10 | import Simple.Core.Evaluation 11 | import Simple.Core.Parser 12 | import Simple.Core.Term 13 | 14 | flushStr :: String -> IO () 15 | flushStr str = putStr str >> hFlush stdout 16 | 17 | readPrompt :: String -> IO String 18 | readPrompt prompt = flushStr prompt >> getLine 19 | 20 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 21 | until_ p prompt action = do 22 | result <- prompt 23 | if p result 24 | then return () 25 | else action result >> until_ p prompt action 26 | 27 | repl :: String -> IO () 28 | repl src = case loadProgram src of 29 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 30 | Right (sig,defs,ctx,i,env) 31 | -> do hSetBuffering stdin LineBuffering 32 | until_ (== ":quit") 33 | (readPrompt "$> ") 34 | (evalAndPrint sig defs ctx i env) 35 | where 36 | loadProgram :: String -> Either String (Signature,Definitions,Context,Int,Environment String Term) 37 | loadProgram src 38 | = do prog <- parseProgram src 39 | ElabState sig defs ctx i <- runElaborator (elabProgram prog) 40 | let env = [ (x,m) | (x,m,_) <- defs ] 41 | return (sig,defs,ctx,i,env) 42 | 43 | loadTerm :: Signature -> Definitions -> Context -> Int -> Environment String Term -> String -> Either String Term 44 | loadTerm sig defs ctx i env src 45 | = do tm <- parseTerm src 46 | case runTypeChecker (infer tm) sig defs ctx i of 47 | Left e -> Left e 48 | Right _ -> runReaderT (eval tm) env 49 | 50 | evalAndPrint :: Signature -> Definitions -> Context -> Int -> Environment String Term -> String -> IO () 51 | evalAndPrint _ _ _ _ _ "" = return () 52 | evalAndPrint sig defs ctx i env src 53 | = case loadTerm sig defs ctx i env src of 54 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 55 | Right v -> flushStr (show v ++ "\n") 56 | 57 | replFile :: String -> IO () 58 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Simple/Monadic/REPL.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Simple.Monadic.REPL where 4 | 5 | import Control.Monad.Reader (runReaderT) 6 | import System.IO 7 | 8 | import Env 9 | import Eval 10 | import Simple.Monadic.Elaboration 11 | import Simple.Monadic.TypeChecking 12 | import Simple.Core.Evaluation () 13 | import Simple.Core.Parser 14 | import Simple.Core.Term 15 | 16 | flushStr :: String -> IO () 17 | flushStr str = putStr str >> hFlush stdout 18 | 19 | readPrompt :: String -> IO String 20 | readPrompt prompt = flushStr prompt >> getLine 21 | 22 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 23 | until_ p prompt action = do 24 | result <- prompt 25 | if p result 26 | then return () 27 | else action result >> until_ p prompt action 28 | 29 | repl :: String -> IO () 30 | repl src0 = case loadProgram src0 of 31 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 32 | Right (sig,defs,ctx,i,env) 33 | -> do hSetBuffering stdin LineBuffering 34 | until_ (== ":quit") 35 | (readPrompt "$> ") 36 | (evalAndPrint sig defs ctx i env) 37 | where 38 | loadProgram :: String -> Either String (Signature,Definitions,Context,Int,Environment String Term) 39 | loadProgram src 40 | = do prog <- parseProgram src 41 | ElabState sig defs ctx i <- runElaborator (elabProgram prog) 42 | let env = definitionsToEnvironment defs 43 | return (sig,defs,ctx,i,env) 44 | 45 | loadTerm :: Signature -> Definitions -> Context -> Int -> Environment String Term -> String -> Either String Term 46 | loadTerm sig defs ctx i env src 47 | = do tm <- parseTerm src 48 | case runTypeChecker (infer tm) sig defs ctx i of 49 | Left e -> Left e 50 | Right _ -> runReaderT (eval tm) env 51 | 52 | evalAndPrint :: Signature -> Definitions -> Context -> Int -> Environment String Term -> String -> IO () 53 | evalAndPrint _ _ _ _ _ "" = return () 54 | evalAndPrint sig defs ctx i env src 55 | = case loadTerm sig defs ctx i env src of 56 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 57 | Right v -> flushStr (show v ++ "\n") 58 | 59 | replFile :: String -> IO () 60 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /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 Env 7 | import Eval 8 | import Dependent.Core.ConSig 9 | import Dependent.Core.Evaluation 10 | import Dependent.Core.Parser 11 | import Dependent.Core.Term 12 | import Dependent.Monadic.Elaboration 13 | import Dependent.Monadic.TypeChecking 14 | 15 | 16 | 17 | flushStr :: String -> IO () 18 | flushStr str = putStr str >> hFlush stdout 19 | 20 | readPrompt :: String -> IO String 21 | readPrompt prompt = flushStr prompt >> getLine 22 | 23 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 24 | until_ p prompt action = do 25 | result <- prompt 26 | if p result 27 | then return () 28 | else action result >> until_ p prompt action 29 | 30 | repl :: String -> IO () 31 | repl src = case loadProgram src of 32 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 33 | Right (sig,defs,ctx,i,env) 34 | -> do hSetBuffering stdin LineBuffering 35 | until_ (== ":quit") 36 | (readPrompt "$> ") 37 | (evalAndPrint sig defs ctx i env) 38 | where 39 | loadProgram :: String -> Either String (Signature Term,Definitions,Context,Int,Environment String Term) 40 | loadProgram src 41 | = do prog <- parseProgram src 42 | ElabState sig defs ctx i <- runElaborator (elabProgram prog) 43 | let env = [ (x,m) | (x,m,_) <- defs ] 44 | return (sig,defs,ctx,i,env) 45 | 46 | loadTerm :: Signature Term -> Definitions -> Context -> Int -> Environment String Term -> String -> Either String Term 47 | loadTerm sig defs ctx i env src 48 | = do tm <- parseTerm src 49 | case runTypeChecker (infer tm) sig defs ctx i of 50 | Left e -> Left e 51 | Right _ -> runReaderT (eval tm) env 52 | 53 | evalAndPrint :: Signature Term -> Definitions -> Context -> Int -> Environment String Term -> String -> IO () 54 | evalAndPrint _ _ _ _ _ "" = return () 55 | evalAndPrint sig defs ctx i env src 56 | = case loadTerm sig defs ctx i env src of 57 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 58 | Right v -> flushStr (show v ++ "\n") 59 | 60 | replFile :: String -> IO () 61 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /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 Env 7 | import Eval 8 | import Dependent.Core.ConSig 9 | import Dependent.Core.Evaluation 10 | import Dependent.Core.Parser 11 | import Dependent.Core.Term 12 | import Dependent.Unification.Elaboration 13 | import Dependent.Unification.TypeChecking 14 | 15 | 16 | 17 | flushStr :: String -> IO () 18 | flushStr str = putStr str >> hFlush stdout 19 | 20 | readPrompt :: String -> IO String 21 | readPrompt prompt = flushStr prompt >> getLine 22 | 23 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 24 | until_ p prompt action = do 25 | result <- prompt 26 | if p result 27 | then return () 28 | else action result >> until_ p prompt action 29 | 30 | repl :: String -> IO () 31 | repl src = case loadProgram src of 32 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 33 | Right (sig,defs,ctx,i,env) 34 | -> do hSetBuffering stdin LineBuffering 35 | until_ (== ":quit") 36 | (readPrompt "$> ") 37 | (evalAndPrint sig defs ctx i env) 38 | where 39 | loadProgram :: String -> Either String (Signature Term,Definitions,Context,Int,Environment String Term) 40 | loadProgram src 41 | = do prog <- parseProgram src 42 | ElabState sig defs ctx i <- runElaborator (elabProgram prog) 43 | let env = [ (x,m) | (x,m,_) <- defs ] 44 | return (sig,defs,ctx,i,env) 45 | 46 | loadTerm :: Signature Term -> Definitions -> Context -> Int -> Environment String Term -> String -> Either String Term 47 | loadTerm sig defs ctx i env src 48 | = do tm <- parseTerm src 49 | case runTypeChecker (infer tm) sig defs ctx i of 50 | Left e -> Left e 51 | Right _ -> runReaderT (eval tm) env 52 | 53 | evalAndPrint :: Signature Term -> Definitions -> Context -> Int -> Environment String Term -> String -> IO () 54 | evalAndPrint _ _ _ _ _ "" = return () 55 | evalAndPrint sig defs ctx i env src 56 | = case loadTerm sig defs ctx i env src of 57 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 58 | Right v -> flushStr (show v ++ "\n") 59 | 60 | replFile :: String -> IO () 61 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /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 Env 7 | import Eval 8 | import DependentImplicit.Core.ConSig 9 | import DependentImplicit.Core.Evaluation 10 | import DependentImplicit.Core.Parser 11 | import DependentImplicit.Core.Term 12 | import DependentImplicit.Unification.Elaboration 13 | import DependentImplicit.Unification.TypeChecking 14 | 15 | 16 | 17 | flushStr :: String -> IO () 18 | flushStr str = putStr str >> hFlush stdout 19 | 20 | readPrompt :: String -> IO String 21 | readPrompt prompt = flushStr prompt >> getLine 22 | 23 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 24 | until_ p prompt action = do 25 | result <- prompt 26 | if p result 27 | then return () 28 | else action result >> until_ p prompt action 29 | 30 | repl :: String -> IO () 31 | repl src = case loadProgram src of 32 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 33 | Right (sig,defs,ctx,i,env) 34 | -> do hSetBuffering stdin LineBuffering 35 | until_ (== ":quit") 36 | (readPrompt "$> ") 37 | (evalAndPrint sig defs ctx i env) 38 | where 39 | loadProgram :: String -> Either String (Signature Term,Definitions,Context,Int,Environment String Term) 40 | loadProgram src 41 | = do prog <- parseProgram src 42 | ElabState sig defs ctx i <- runElaborator (elabProgram prog) 43 | let env = [ (x,m) | (x,m,_) <- defs ] 44 | return (sig,defs,ctx,i,env) 45 | 46 | loadTerm :: Signature Term -> Definitions -> Context -> Int -> Environment String Term -> String -> Either String Term 47 | loadTerm sig defs ctx i env src 48 | = do tm <- parseTerm src 49 | case runTypeChecker (infer tm) sig defs ctx i of 50 | Left e -> Left e 51 | Right ((tm',_),_) -> runReaderT (eval tm') env 52 | 53 | evalAndPrint :: Signature Term -> Definitions -> Context -> Int -> Environment String Term -> String -> IO () 54 | evalAndPrint _ _ _ _ _ "" = return () 55 | evalAndPrint sig defs ctx i env src 56 | = case loadTerm sig defs ctx i env src of 57 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 58 | Right v -> flushStr (show v ++ "\n") 59 | 60 | replFile :: String -> IO () 61 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Dependent/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module Dependent.Core.Evaluation where 7 | 8 | import Control.Monad.Except 9 | 10 | import Env 11 | import Eval 12 | import Scope 13 | import Dependent.Core.Term 14 | 15 | 16 | 17 | -- Pattern Matching 18 | 19 | matchPattern :: Pattern -> Term -> Maybe [Term] 20 | matchPattern (VarPat _) v = Just [v] 21 | matchPattern (ConPat c ps) (Con c' as) | c == c' 22 | = fmap concat $ zipWithM matchPattern ps as 23 | matchPattern (AssertionPat _) _ = Just [] 24 | matchPattern _ _ = Nothing 25 | 26 | matchPatterns :: [Pattern] -> [Term] -> Maybe [Term] 27 | matchPatterns [] [] 28 | = Just [] 29 | matchPatterns (p:ps) (m:ms) 30 | = do vs <- matchPattern p m 31 | vs' <- matchPatterns ps ms 32 | return $ vs ++ vs' 33 | matchPatterns _ _ 34 | = Nothing 35 | 36 | matchClauses :: [Clause] -> [Term] -> Maybe Term 37 | matchClauses [] _ = Nothing 38 | matchClauses (Clause psc sc:cs) ms 39 | = case matchPatterns (descope Name psc) ms of 40 | Nothing -> matchClauses cs ms 41 | Just vs -> Just (instantiate sc (removeByDummies (names psc) vs)) 42 | 43 | 44 | 45 | -- Standard Eager Evaluation 46 | 47 | instance Eval (Environment String Term) Term where 48 | eval (Meta i) 49 | = return $ Meta i 50 | eval (Var (Name x)) 51 | = do env <- environment 52 | case lookup x env of 53 | Nothing -> throwError $ "Unknown constant/defined term: " ++ x 54 | Just m -> eval m 55 | eval (Var (Generated x i)) 56 | = return $ Var (Generated x i) 57 | eval (Ann m _) 58 | = eval m 59 | eval Type 60 | = return Type 61 | eval (Fun a sc) 62 | = return $ Fun a sc 63 | eval (Lam sc) 64 | = return $ Lam sc 65 | eval (App f a) 66 | = do ef <- eval f 67 | ea <- eval a 68 | case ef of 69 | Lam sc -> eval (instantiate sc [ea]) 70 | _ -> return $ App ef ea 71 | eval (Con c as) 72 | = do eas <- mapM eval as 73 | return $ Con c eas 74 | eval (Case ms mot cs) 75 | = do ems <- mapM eval ms 76 | case matchClauses cs ems of 77 | Nothing -> if any (\p -> case p of { (Con _ _) -> False ; _ -> True }) ems 78 | then return (Case ms mot cs) 79 | else throwError $ "Incomplete pattern match: " ++ show (Case ms mot cs) 80 | Just b -> eval b -------------------------------------------------------------------------------- /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 Env 7 | import Eval 8 | import Record.Core.ConSig 9 | import Record.Core.Evaluation 10 | import Record.Core.Parser 11 | import Record.Core.Term 12 | import Record.Unification.Elaboration 13 | import Record.Unification.TypeChecking 14 | 15 | 16 | 17 | flushStr :: String -> IO () 18 | flushStr str = putStr str >> hFlush stdout 19 | 20 | readPrompt :: String -> IO String 21 | readPrompt prompt = flushStr prompt >> getLine 22 | 23 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 24 | until_ p prompt action = do 25 | result <- prompt 26 | if p result 27 | then return () 28 | else action result >> until_ p prompt action 29 | 30 | repl :: String -> IO () 31 | repl src = case loadProgram src of 32 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 33 | Right (sig,defs,ctx,i,env,ms) 34 | -> do hSetBuffering stdin LineBuffering 35 | until_ (== ":quit") 36 | (readPrompt "$> ") 37 | (evalAndPrint sig defs ctx i env ms) 38 | where 39 | loadProgram :: String -> Either String (Signature Term,Definitions,Context,Int,Environment (String,String) Term,[String]) 40 | loadProgram src 41 | = do prog <- parseProgram src 42 | ElabState sig defs ctx i _ _ ms <- runElaborator (elabProgram prog) 43 | let env = [ (x,m) | (x,m,_) <- defs ] 44 | return (sig,defs,ctx,i,env,ms) 45 | 46 | loadTerm :: Signature Term -> Definitions -> Context -> Int -> Environment (String,String) Term -> [String] -> String -> Either String Term 47 | loadTerm sig defs ctx i env ms src 48 | = do tm <- parseTerm src 49 | case runTypeChecker (infer tm) sig defs ctx i ([ (Right p,p) | (p,_) <- sig ] ++ [ (Right p,p) | (p,_,_) <- defs ]) ms of 50 | Left e -> Left e 51 | Right ((tm',_),_) -> runReaderT (eval tm') env 52 | 53 | evalAndPrint :: Signature Term -> Definitions -> Context -> Int -> Environment (String,String) Term -> [String] -> String -> IO () 54 | evalAndPrint _ _ _ _ _ _ "" = return () 55 | evalAndPrint sig defs ctx i env ms src 56 | = case loadTerm sig defs ctx i env ms src of 57 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 58 | Right v -> flushStr (show v ++ "\n") 59 | 60 | replFile :: String -> IO () 61 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /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 Env 7 | import Eval 8 | import Modular.Core.ConSig 9 | import Modular.Core.Evaluation 10 | import Modular.Core.Parser 11 | import Modular.Core.Term 12 | import Modular.Unification.Elaboration 13 | import Modular.Unification.TypeChecking 14 | 15 | 16 | 17 | flushStr :: String -> IO () 18 | flushStr str = putStr str >> hFlush stdout 19 | 20 | readPrompt :: String -> IO String 21 | readPrompt prompt = flushStr prompt >> getLine 22 | 23 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 24 | until_ p prompt action = do 25 | result <- prompt 26 | if p result 27 | then return () 28 | else action result >> until_ p prompt action 29 | 30 | repl :: String -> IO () 31 | repl src = case loadProgram src of 32 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 33 | Right (sig,defs,ctx,i,env,ms) 34 | -> do hSetBuffering stdin LineBuffering 35 | until_ (== ":quit") 36 | (readPrompt "$> ") 37 | (evalAndPrint sig defs ctx i env ms) 38 | where 39 | loadProgram :: String -> Either String (Signature Term,Definitions,Context,Int,Environment (String,String) Term,[String]) 40 | loadProgram src 41 | = do prog <- parseProgram src 42 | ElabState sig defs ctx i _ _ ms <- runElaborator (elabProgram prog) 43 | let env = [ (x,m) | (x,m,_) <- defs ] 44 | return (sig,defs,ctx,i,env,ms) 45 | 46 | loadTerm :: Signature Term -> Definitions -> Context -> Int -> Environment (String,String) Term -> [String] -> String -> Either String Term 47 | loadTerm sig defs ctx i env ms src 48 | = do tm <- parseTerm src 49 | case runTypeChecker (infer tm) sig defs ctx i ([ (Right p,p) | (p,_) <- sig ] ++ [ (Right p,p) | (p,_,_) <- defs ]) ms of 50 | Left e -> Left e 51 | Right ((tm',_),_) -> runReaderT (eval tm') env 52 | 53 | evalAndPrint :: Signature Term -> Definitions -> Context -> Int -> Environment (String,String) Term -> [String] -> String -> IO () 54 | evalAndPrint _ _ _ _ _ _ "" = return () 55 | evalAndPrint sig defs ctx i env ms src 56 | = case loadTerm sig defs ctx i env ms src of 57 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 58 | Right v -> flushStr (show v ++ "\n") 59 | 60 | replFile :: String -> IO () 61 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /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 Env 7 | import Eval 8 | import OpenDefs.Core.ConSig 9 | import OpenDefs.Core.Evaluation 10 | import OpenDefs.Core.Parser 11 | import OpenDefs.Core.Term 12 | import OpenDefs.Unification.Elaboration 13 | import OpenDefs.Unification.TypeChecking 14 | 15 | 16 | 17 | flushStr :: String -> IO () 18 | flushStr str = putStr str >> hFlush stdout 19 | 20 | readPrompt :: String -> IO String 21 | readPrompt prompt = flushStr prompt >> getLine 22 | 23 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 24 | until_ p prompt action = do 25 | result <- prompt 26 | if p result 27 | then return () 28 | else action result >> until_ p prompt action 29 | 30 | repl :: String -> IO () 31 | repl src = case loadProgram src of 32 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 33 | Right (sig,defs,ctx,i,env,ms) 34 | -> do hSetBuffering stdin LineBuffering 35 | until_ (== ":quit") 36 | (readPrompt "$> ") 37 | (evalAndPrint sig defs ctx i env ms) 38 | where 39 | loadProgram :: String -> Either String (Signature Term,Definitions,Context,Int,Environment (String,String) Term,[String]) 40 | loadProgram src 41 | = do prog <- parseProgram src 42 | ElabState sig defs ctx i _ _ ms _ _ <- runElaborator (elabProgram prog) 43 | let env = [ (x,m) | (x,m,_) <- defs ] 44 | return (sig,defs,ctx,i,env,ms) 45 | 46 | loadTerm :: Signature Term -> Definitions -> Context -> Int -> Environment (String,String) Term -> [String] -> String -> Either String Term 47 | loadTerm sig defs ctx i env ms src 48 | = do tm <- parseTerm src 49 | case runTypeChecker (infer tm) sig defs ctx i ([ (Right p,p) | (p,_) <- sig ] ++ [ (Right p,p) | (p,_,_) <- defs ]) ms of 50 | Left e -> Left e 51 | Right ((tm',_),_) -> runReaderT (eval tm') env 52 | 53 | evalAndPrint :: Signature Term -> Definitions -> Context -> Int -> Environment (String,String) Term -> [String] -> String -> IO () 54 | evalAndPrint _ _ _ _ _ _ "" = return () 55 | evalAndPrint sig defs ctx i env ms src 56 | = case loadTerm sig defs ctx i env ms src of 57 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 58 | Right v -> flushStr (show v ++ "\n") 59 | 60 | replFile :: String -> IO () 61 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /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 Env 7 | import Eval 8 | import Quasiquote.Core.ConSig 9 | import Quasiquote.Core.Evaluation 10 | import Quasiquote.Core.Parser 11 | import Quasiquote.Core.Term 12 | import Quasiquote.Unification.Elaboration 13 | import Quasiquote.Unification.TypeChecking 14 | 15 | 16 | 17 | flushStr :: String -> IO () 18 | flushStr str = putStr str >> hFlush stdout 19 | 20 | readPrompt :: String -> IO String 21 | readPrompt prompt = flushStr prompt >> getLine 22 | 23 | until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () 24 | until_ p prompt action = do 25 | result <- prompt 26 | if p result 27 | then return () 28 | else action result >> until_ p prompt action 29 | 30 | repl :: String -> IO () 31 | repl src = case loadProgram src of 32 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 33 | Right (sig,defs,ctx,i,env,ms) 34 | -> do hSetBuffering stdin LineBuffering 35 | until_ (== ":quit") 36 | (readPrompt "$> ") 37 | (evalAndPrint sig defs ctx i env ms) 38 | where 39 | loadProgram :: String -> Either String (Signature Term,Definitions,Context,Int,Environment (String,String) Term,[String]) 40 | loadProgram src 41 | = do prog <- parseProgram src 42 | ElabState sig defs ctx i _ _ ms _ _ <- runElaborator (elabProgram prog) 43 | let env = [ (x,m) | (x,m,_) <- defs ] 44 | return (sig,defs,ctx,i,env,ms) 45 | 46 | loadTerm :: Signature Term -> Definitions -> Context -> Int -> Environment (String,String) Term -> [String] -> String -> Either String Term 47 | loadTerm sig defs ctx i env ms src 48 | = do tm <- parseTerm src 49 | case runTypeChecker (infer tm) sig defs ctx i ([ (Right p,p) | (p,_) <- sig ] ++ [ (Right p,p) | (p,_,_) <- defs ]) ms of 50 | Left e -> Left e 51 | Right ((tm',_),_) -> runReaderT (eval tm') env 52 | 53 | evalAndPrint :: Signature Term -> Definitions -> Context -> Int -> Environment (String,String) Term -> [String] -> String -> IO () 54 | evalAndPrint _ _ _ _ _ _ "" = return () 55 | evalAndPrint sig defs ctx i env ms src 56 | = case loadTerm sig defs ctx i env ms src of 57 | Left e -> flushStr ("ERROR: " ++ e ++ "\n") 58 | Right v -> flushStr (show v ++ "\n") 59 | 60 | replFile :: String -> IO () 61 | replFile loc = readFile loc >>= repl -------------------------------------------------------------------------------- /src/Simple/Core/Abstraction.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module Simple.Core.Abstraction where 7 | 8 | import Control.Monad.Reader 9 | import qualified Control.Monad.State as S 10 | 11 | import Abs 12 | import Scope 13 | 14 | import Simple.Core.Term 15 | import Simple.Core.Type 16 | 17 | 18 | 19 | -- Abstraction 20 | 21 | abstractClause :: Clause -> Abstracted String Term Clause 22 | abstractClause (Clause p sc) 23 | = Clause p <$> abstractScope sc 24 | 25 | instance Abstract String Term Term where 26 | abstract (Var (Name x)) 27 | = reader $ \e -> 28 | case lookup x e of 29 | Nothing -> Var (Name x) 30 | Just m -> m 31 | abstract (Var (Generated x i)) 32 | = return $ Var (Generated x i) 33 | abstract (Ann m ty) 34 | = Ann <$> abstract m <*> return ty 35 | abstract (Lam sc) 36 | = Lam <$> abstractScope sc 37 | abstract (App f a) 38 | = App <$> abstract f <*> abstract a 39 | abstract (Con c as) 40 | = Con c <$> mapM abstract as 41 | abstract (Case a cs) 42 | = Case <$> mapM abstract a <*> mapM abstractClause cs 43 | 44 | instance Abstract String Variable Pattern where 45 | abstract (VarPat (Name x)) 46 | = reader $ \e -> 47 | case lookup x e of 48 | Nothing -> VarPat (Name x) 49 | Just y -> VarPat y 50 | abstract (VarPat (Generated x i)) 51 | = return $ VarPat (Generated x i) 52 | abstract (ConPat c ps) 53 | = ConPat c <$> mapM abstract ps 54 | 55 | lamHelper :: String -> Term -> Term 56 | lamHelper x b = Lam (scope [x] b) 57 | 58 | clauseHelper :: [Pattern] -> [String] -> Term -> Clause 59 | clauseHelper ps xs b = Clause (scope2 xs cleanedXs cleanedPs) (scope (filter isVar xs) b) 60 | where 61 | cleanedXs = fst (S.runState (mapM cleanXs xs) 0) 62 | 63 | cleanXs :: String -> S.State Int String 64 | cleanXs "_" = do i <- S.get 65 | S.put (i+1) 66 | return $ "$" ++ show i 67 | cleanXs x = return x 68 | 69 | cleanedPs = fst (S.runState (mapM cleanPs ps) 0) 70 | 71 | cleanPs :: Pattern -> S.State Int Pattern 72 | cleanPs (VarPat (Name "_")) 73 | = do i <- S.get 74 | S.put (i+1) 75 | return $ VarPat (Name ("$" ++ show i)) 76 | cleanPs (VarPat (Name n)) 77 | = return $ VarPat (Name n) 78 | cleanPs (VarPat (Generated n i)) 79 | = return $ VarPat (Generated n i) 80 | cleanPs (ConPat c ps) 81 | = ConPat c <$> mapM cleanPs ps -------------------------------------------------------------------------------- /src/TypeChecker.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | module TypeChecker where 8 | 9 | import Control.Monad.State 10 | 11 | class TypeCheckerState s where 12 | type Sig s 13 | type Defs s 14 | type Ctx s 15 | typeCheckerSig :: s -> Sig s 16 | putTypeCheckerSig :: s -> Sig s -> s 17 | typeCheckerDefs :: s -> Defs s 18 | putTypeCheckerDefs :: s -> Defs s -> s 19 | addTypeCheckerDefs :: s -> Defs s -> s 20 | typeCheckerCtx :: s -> Ctx s 21 | putTypeCheckerCtx :: s -> Ctx s -> s 22 | addTypeCheckerCtx :: s -> Ctx s -> s 23 | typeCheckerNextName :: s -> Int 24 | putTypeCheckerNextName :: s -> Int -> s 25 | 26 | 27 | 28 | type MonadTC s m = (TypeCheckerState s, Functor m, MonadState s m) 29 | 30 | signature :: MonadTC s m => m (Sig s) 31 | signature = fmap typeCheckerSig get 32 | 33 | putSignature :: MonadTC s m => Sig s -> m () 34 | putSignature sig 35 | = do s <- get 36 | put (putTypeCheckerSig s sig) 37 | 38 | definitions :: MonadTC s m => m (Defs s) 39 | definitions = fmap typeCheckerDefs get 40 | 41 | putDefinitions :: MonadTC s m => Defs s -> m () 42 | putDefinitions defs 43 | = do s <- get 44 | put (putTypeCheckerDefs s defs) 45 | 46 | extendDefinitions :: MonadTC s m => Defs s -> m a -> m a 47 | extendDefinitions edefs tc 48 | = do s <- get 49 | put (addTypeCheckerDefs s edefs) 50 | x <- tc 51 | putDefinitions (typeCheckerDefs s) 52 | return x 53 | 54 | context :: MonadTC s m => m (Ctx s) 55 | context = fmap typeCheckerCtx get 56 | 57 | putContext :: MonadTC s m => Ctx s -> m () 58 | putContext ctx 59 | = do s <- get 60 | put (putTypeCheckerCtx s ctx) 61 | 62 | extendContext :: MonadTC s m => Ctx s -> m a -> m a 63 | extendContext ectx tc 64 | = do s <- get 65 | put (addTypeCheckerCtx s ectx) 66 | x <- tc 67 | putContext (typeCheckerCtx s) 68 | return x 69 | 70 | newName :: MonadTC s m => m Int 71 | newName = do s <- get 72 | let n = typeCheckerNextName s 73 | put (putTypeCheckerNextName s (n+1)) 74 | return $ n 75 | 76 | 77 | 78 | class TypeCheckerMetas s where 79 | type Subs s 80 | typeCheckerNextMeta :: s -> Int 81 | putTypeCheckerNextMeta :: s -> Int -> s 82 | typeCheckerSubs :: s -> Subs s 83 | putTypeCheckerSubs :: s -> Subs s -> s 84 | 85 | type MonadPolyTC s m = (TypeCheckerMetas s, MonadTC s m) 86 | 87 | newMetaVar :: MonadPolyTC s m => m Int 88 | newMetaVar = do s <- get 89 | let n = typeCheckerNextMeta s 90 | put (putTypeCheckerNextMeta s (n+1)) 91 | return n 92 | 93 | substitution :: MonadPolyTC s m => m (Subs s) 94 | substitution = fmap typeCheckerSubs get 95 | 96 | putSubstitution :: MonadPolyTC s m => Subs s -> m () 97 | putSubstitution subs = do s <- get 98 | put (putTypeCheckerSubs s subs) -------------------------------------------------------------------------------- /src/Modular/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module Modular.Core.Evaluation where 7 | 8 | import Control.Monad.Except 9 | 10 | import Env 11 | import Eval 12 | import Plicity 13 | import Scope 14 | import Modular.Core.Term 15 | 16 | 17 | 18 | 19 | -- 20 | -- NOTE 21 | -- 22 | -- Plicity mismatches should never occur in evaluable code, so they throw 23 | -- actual Haskell errors, not internal language errors. 24 | -- 25 | 26 | 27 | -- Pattern Matching 28 | 29 | matchPattern :: Pattern -> Term -> Maybe [Term] 30 | matchPattern (VarPat _) v = Just [v] 31 | matchPattern (ConPat c ps) (Con c' as) | c == c' 32 | = matchPatterns ps as 33 | matchPattern (AssertionPat _) _ = Just [] 34 | matchPattern _ _ = Nothing 35 | 36 | matchPatterns :: [(Plicity,Pattern)] -> [(Plicity,Term)] -> Maybe [Term] 37 | matchPatterns [] [] 38 | = Just [] 39 | matchPatterns ((plic,p):ps) ((plic',m):ms) 40 | | plic == plic' 41 | = do vs <- matchPattern p m 42 | vs' <- matchPatterns ps ms 43 | return $ vs ++ vs' 44 | | otherwise 45 | = error "Mismatching plicity in pattern match." 46 | matchPatterns _ _ 47 | = Nothing 48 | 49 | matchClauses :: [Clause] -> [(Plicity,Term)] -> Maybe Term 50 | matchClauses [] _ = Nothing 51 | matchClauses (Clause psc sc:cs) ms 52 | = case matchPatterns [ (Expl,p) | p <- descope Name psc ] ms of 53 | Nothing -> matchClauses cs ms 54 | Just vs -> Just (instantiate sc (removeByDummies (names psc) vs)) 55 | 56 | 57 | 58 | -- Standard Eager Evaluation 59 | 60 | instance Eval (Environment (String,String) Term) Term where 61 | eval (Meta i) 62 | = return $ Meta i 63 | eval (Var x) 64 | = return $ Var x 65 | eval (DottedVar mdl var) 66 | = do env <- environment 67 | case lookup (mdl,var) env of 68 | Nothing -> throwError $ "Unknown constant/defined term: " ++ show (DottedVar mdl var) 69 | Just m -> eval m 70 | eval (Ann m _) 71 | = eval m 72 | eval Type 73 | = return Type 74 | eval (Fun plic a sc) 75 | = return $ Fun plic a sc 76 | eval (Lam plic sc) 77 | = return $ Lam plic sc 78 | eval (App plic f a) 79 | = do ef <- eval f 80 | ea <- eval a 81 | case ef of 82 | Lam plic' sc 83 | | plic == plic' -> eval (instantiate sc [ea]) 84 | | otherwise -> error "Mismatching plicity in function application." 85 | _ -> return $ App plic ef ea 86 | eval (Con c as) 87 | = do eas <- forM as $ \(plic,a) -> 88 | do a' <- eval a 89 | return (plic,a') 90 | return $ Con c eas 91 | eval (Case ms mot cs) 92 | = do ems <- mapM eval ms 93 | case matchClauses cs [ (Expl,em) | em <- ems ] of 94 | Nothing -> if any (\p -> case p of { (Con _ _) -> False ; _ -> True }) ems 95 | then return (Case ms mot cs) 96 | else throwError $ "Incomplete pattern match: " ++ show (Case ms mot cs) 97 | Just b -> eval b -------------------------------------------------------------------------------- /src/DependentImplicit/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module DependentImplicit.Core.Evaluation where 7 | 8 | import Control.Monad.Except 9 | 10 | import Env 11 | import Eval 12 | import Plicity 13 | import Scope 14 | import DependentImplicit.Core.Term 15 | 16 | 17 | 18 | 19 | -- 20 | -- NOTE 21 | -- 22 | -- Plicity mismatches should never occur in evaluable code, so they throw 23 | -- actual Haskell errors, not internal language errors. 24 | -- 25 | 26 | 27 | -- Pattern Matching 28 | 29 | matchPattern :: Pattern -> Term -> Maybe [Term] 30 | matchPattern (VarPat _) v = Just [v] 31 | matchPattern (ConPat c ps) (Con c' as) | c == c' 32 | = matchPatterns ps as 33 | matchPattern (AssertionPat _) _ = Just [] 34 | matchPattern _ _ = Nothing 35 | 36 | matchPatterns :: [(Plicity,Pattern)] -> [(Plicity,Term)] -> Maybe [Term] 37 | matchPatterns [] [] 38 | = Just [] 39 | matchPatterns ((plic,p):ps) ((plic',m):ms) 40 | | plic == plic' 41 | = do vs <- matchPattern p m 42 | vs' <- matchPatterns ps ms 43 | return $ vs ++ vs' 44 | | otherwise 45 | = error "Mismatching plicity in pattern match." 46 | matchPatterns _ _ 47 | = Nothing 48 | 49 | matchClauses :: [Clause] -> [(Plicity,Term)] -> Maybe Term 50 | matchClauses [] _ = Nothing 51 | matchClauses (Clause psc sc:cs) ms 52 | = case matchPatterns [ (Expl,p) | p <- descope Name psc ] ms of 53 | Nothing -> matchClauses cs ms 54 | Just vs -> Just (instantiate sc (removeByDummies (names psc) vs)) 55 | 56 | 57 | 58 | -- Standard Eager Evaluation 59 | 60 | instance Eval (Environment String Term) Term where 61 | eval (Meta i) 62 | = return $ Meta i 63 | eval (Var (Name x)) 64 | = do env <- environment 65 | case lookup x env of 66 | Nothing -> throwError $ "Unknown constant/defined term: " ++ x 67 | Just m -> eval m 68 | eval (Var (Generated x i)) 69 | = return $ Var (Generated x i) 70 | eval (Ann m _) 71 | = eval m 72 | eval Type 73 | = return Type 74 | eval (Fun plic a sc) 75 | = return $ Fun plic a sc 76 | eval (Lam plic sc) 77 | = return $ Lam plic sc 78 | eval (App plic f a) 79 | = do ef <- eval f 80 | ea <- eval a 81 | case ef of 82 | Lam plic' sc 83 | | plic == plic' -> eval (instantiate sc [ea]) 84 | | otherwise -> error "Mismatching plicity in function application." 85 | _ -> return $ App plic ef ea 86 | eval (Con c as) 87 | = do eas <- forM as $ \(plic,a) -> 88 | do a' <- eval a 89 | return (plic,a') 90 | return $ Con c eas 91 | eval (Case ms mot cs) 92 | = do ems <- mapM eval ms 93 | case matchClauses cs [ (Expl,em) | em <- ems ] of 94 | Nothing -> if any (\p -> case p of { (Con _ _) -> False ; _ -> True }) ems 95 | then return (Case ms mot cs) 96 | else throwError $ "Incomplete pattern match: " ++ show (Case ms mot cs) 97 | Just b -> eval b -------------------------------------------------------------------------------- /src/Simple/Core/Term.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | 7 | module Simple.Core.Term where 8 | 9 | import Data.List (intercalate) 10 | 11 | import Parens 12 | import Scope 13 | import Simple.Core.Type 14 | 15 | 16 | 17 | -- Terms 18 | 19 | data Variable 20 | = Name String 21 | | Generated String Int 22 | 23 | data Term 24 | = Var Variable 25 | | Ann Term Type 26 | | Lam (Scope Term Term) 27 | | App Term Term 28 | | Con String [Term] 29 | | Case [Term] [Clause] 30 | 31 | data Clause 32 | = Clause (Scope Variable [Pattern]) (Scope Term Term) 33 | 34 | data Pattern 35 | = VarPat Variable 36 | | ConPat String [Pattern] 37 | 38 | 39 | 40 | -- Show Instances 41 | 42 | instance Show Variable where 43 | show (Name x) = x 44 | show (Generated x _) = x 45 | 46 | data PatternParenLoc = ConPatArg 47 | deriving (Eq) 48 | 49 | instance ParenLoc Pattern where 50 | type Loc Pattern = PatternParenLoc 51 | parenLoc (VarPat _) = [ConPatArg] 52 | parenLoc (ConPat _ []) = [ConPatArg] 53 | parenLoc (ConPat _ _) = [] 54 | 55 | instance ParenRec Pattern where 56 | parenRec (VarPat x) 57 | = show x 58 | parenRec (ConPat c []) 59 | = c 60 | parenRec (ConPat c ps) 61 | = c ++ " " ++ unwords (map (parenthesize (Just ConPatArg)) ps) 62 | 63 | 64 | data TermParenLoc = AnnLeft | LamBody | AppLeft | AppRight | ConArg | CaseArg 65 | deriving (Eq) 66 | 67 | instance ParenLoc Term where 68 | type Loc Term = TermParenLoc 69 | parenLoc (Var _) 70 | = [AnnLeft,LamBody,AppLeft,AppRight,ConArg,CaseArg] 71 | parenLoc (Ann _ _) 72 | = [LamBody,CaseArg] 73 | parenLoc (Lam _) 74 | = [LamBody,CaseArg] 75 | parenLoc (App _ _) 76 | = [AnnLeft,LamBody,AppLeft,CaseArg] 77 | parenLoc (Con _ []) 78 | = [AnnLeft,LamBody,AppLeft,AppRight,ConArg,CaseArg] 79 | parenLoc (Con _ _) 80 | = [AnnLeft,LamBody,CaseArg] 81 | parenLoc (Case _ _) 82 | = [LamBody] 83 | 84 | instance ParenRec Term where 85 | parenRec (Var (Name x)) 86 | = x 87 | parenRec (Var (Generated x _)) 88 | = x 89 | parenRec (Ann m t) 90 | = parenthesize (Just AnnLeft) m ++ " : " ++ show t 91 | parenRec (Lam sc) 92 | = "\\" ++ unwords (names sc) ++ " -> " 93 | ++ parenthesize (Just LamBody) 94 | (descope (Var . Name) sc) 95 | parenRec (App f a) 96 | = parenthesize (Just AppLeft) f 97 | ++ " " 98 | ++ parenthesize (Just AppRight) a 99 | parenRec (Con c []) 100 | = c 101 | parenRec (Con c as) 102 | = c ++ " " ++ intercalate " " (map (parenthesize (Just ConArg)) as) 103 | parenRec (Case as cs) 104 | = "case " ++ intercalate " || " (map (parenthesize (Just CaseArg)) as) ++ " of " 105 | ++ intercalate " | " (map auxClause cs) ++ " end" 106 | where 107 | auxClause (Clause psc sc) 108 | = intercalate " || " (map (parenthesize Nothing) (descope Name psc)) ++ " -> " 109 | ++ parenthesize Nothing (descope (Var . Name) sc) 110 | 111 | instance Show Term where 112 | show t = parenthesize Nothing t -------------------------------------------------------------------------------- /src/Poly/Core/Term.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | 7 | module Poly.Core.Term where 8 | 9 | import Data.List (intercalate) 10 | 11 | import Parens 12 | import Scope 13 | import Poly.Core.Type 14 | 15 | 16 | 17 | -- Terms 18 | 19 | data Variable 20 | = Name String 21 | | Generated String Int 22 | 23 | data Term 24 | = Var Variable 25 | | Ann Term Type 26 | | Lam (Scope Term Term) 27 | | App Term Term 28 | | Con String [Term] 29 | | Case [Term] [Clause] 30 | 31 | data Clause 32 | = Clause (Scope Variable [Pattern]) (Scope Term Term) 33 | 34 | data Pattern 35 | = VarPat Variable 36 | | ConPat String [Pattern] 37 | 38 | 39 | 40 | -- Show Instances 41 | 42 | instance Show Variable where 43 | show (Name x) = x 44 | show (Generated x _) = x 45 | 46 | data PatternParenLoc = ConPatArg 47 | deriving (Eq) 48 | 49 | instance ParenLoc Pattern where 50 | type Loc Pattern = PatternParenLoc 51 | parenLoc (VarPat _) = [ConPatArg] 52 | parenLoc (ConPat _ []) = [ConPatArg] 53 | parenLoc (ConPat _ _) = [] 54 | 55 | instance ParenRec Pattern where 56 | parenRec (VarPat x) 57 | = show x 58 | parenRec (ConPat c []) 59 | = c 60 | parenRec (ConPat c ps) 61 | = c ++ " " ++ unwords (map (parenthesize (Just ConPatArg)) ps) 62 | 63 | 64 | data TermParenLoc = RootTerm | AnnLeft | LamBody | AppLeft | AppRight | ConArg | CaseArg 65 | deriving (Eq) 66 | 67 | instance ParenLoc Term where 68 | type Loc Term = TermParenLoc 69 | parenLoc (Var _) 70 | = [RootTerm,AnnLeft,LamBody,AppLeft,AppRight,ConArg,CaseArg] 71 | parenLoc (Ann _ _) 72 | = [RootTerm,LamBody,CaseArg] 73 | parenLoc (Lam _) 74 | = [RootTerm,LamBody,CaseArg] 75 | parenLoc (App _ _) 76 | = [RootTerm,AnnLeft,LamBody,AppLeft,CaseArg] 77 | parenLoc (Con _ []) 78 | = [RootTerm,AnnLeft,LamBody,AppLeft,AppRight,ConArg,CaseArg] 79 | parenLoc (Con _ _) 80 | = [RootTerm,AnnLeft,LamBody,CaseArg] 81 | parenLoc (Case _ _) 82 | = [RootTerm,LamBody] 83 | 84 | instance ParenRec Term where 85 | parenRec (Var (Name x)) 86 | = x 87 | parenRec (Var (Generated x _)) 88 | = x 89 | parenRec (Ann m t) 90 | = parenthesize (Just AnnLeft) m ++ " : " ++ show t 91 | parenRec (Lam sc) 92 | = "\\" ++ unwords (names sc) ++ " -> " 93 | ++ parenthesize (Just LamBody) 94 | (descope (Var . Name) sc) 95 | parenRec (App f a) 96 | = parenthesize (Just AppLeft) f ++ " " ++ parenthesize (Just AppRight) a 97 | parenRec (Con c []) 98 | = c 99 | parenRec (Con c as) 100 | = c ++ " " ++ intercalate " " (map (parenthesize (Just ConArg)) as) 101 | parenRec (Case as cs) 102 | = "case " ++ intercalate " || " (map (parenthesize (Just CaseArg)) as) ++ " of " 103 | ++ intercalate " | " (map auxClause cs) ++ " end" 104 | where 105 | auxClause (Clause psc sc) 106 | = intercalate " || " (map (parenthesize Nothing) (descope Name psc)) ++ " -> " 107 | ++ parenthesize Nothing (descope (Var . Name) sc) 108 | 109 | instance Show Term where 110 | show t = parenthesize Nothing t -------------------------------------------------------------------------------- /src/Poly/Core/Abstraction.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module Poly.Core.Abstraction where 7 | 8 | import Control.Monad.Reader 9 | import qualified Control.Monad.State as S 10 | 11 | import Abs 12 | import Scope 13 | 14 | import Poly.Core.Term 15 | import Poly.Core.Type 16 | 17 | 18 | 19 | 20 | -- Abstraction 21 | 22 | abstractClause :: Clause -> Abstracted String Term Clause 23 | abstractClause (Clause p sc) 24 | = Clause p <$> abstractScope sc 25 | 26 | instance Abstract String Term Term where 27 | abstract (Var (Name x)) 28 | = reader $ \e -> 29 | case lookup x e of 30 | Nothing -> Var (Name x) 31 | Just m -> m 32 | abstract (Var (Generated x i)) 33 | = return $ Var (Generated x i) 34 | abstract (Ann m ty) 35 | = Ann <$> abstract m <*> return ty 36 | abstract (Lam sc) 37 | = Lam <$> abstractScope sc 38 | abstract (App f a) 39 | = App <$> abstract f <*> abstract a 40 | abstract (Con c as) 41 | = Con c <$> mapM abstract as 42 | abstract (Case a cs) 43 | = Case <$> mapM abstract a <*> mapM abstractClause cs 44 | 45 | instance Abstract String Variable Pattern where 46 | abstract (VarPat (Name x)) 47 | = reader $ \e -> 48 | case lookup x e of 49 | Nothing -> VarPat (Name x) 50 | Just y -> VarPat y 51 | abstract (VarPat (Generated x i)) 52 | = return $ VarPat (Generated x i) 53 | abstract (ConPat c ps) 54 | = ConPat c <$> mapM abstract ps 55 | 56 | lamHelper :: String -> Term -> Term 57 | lamHelper x b = Lam (scope [x] b) 58 | 59 | clauseHelper :: [Pattern] -> [String] -> Term -> Clause 60 | clauseHelper ps xs b = Clause (scope2 xs cleanedXs cleanedPs) (scope (filter isVar xs) b) 61 | where 62 | cleanedXs = fst (S.runState (mapM cleanXs xs) 0) 63 | 64 | cleanXs :: String -> S.State Int String 65 | cleanXs "_" = do i <- S.get 66 | S.put (i+1) 67 | return $ "$" ++ show i 68 | cleanXs x = return x 69 | 70 | cleanedPs = fst (S.runState (mapM cleanPs ps) 0) 71 | 72 | cleanPs :: Pattern -> S.State Int Pattern 73 | cleanPs (VarPat (Name "_")) 74 | = do i <- S.get 75 | S.put (i+1) 76 | return $ VarPat (Name ("$" ++ show i)) 77 | cleanPs (VarPat (Name n)) 78 | = return $ VarPat (Name n) 79 | cleanPs (VarPat (Generated n i)) 80 | = return $ VarPat (Generated n i) 81 | cleanPs (ConPat c ps) 82 | = ConPat c <$> mapM cleanPs ps 83 | 84 | instance Abstract String Type Type where 85 | abstract (Meta i) 86 | = return $ Meta i 87 | abstract (TyVar (TyName x)) 88 | = reader $ \e -> 89 | case lookup x e of 90 | Nothing -> TyVar (TyName x) 91 | Just m -> m 92 | abstract (TyVar (TyGenerated x i)) 93 | = return $ TyVar (TyGenerated x i) 94 | abstract (TyCon c as) 95 | = TyCon c <$> mapM abstract as 96 | abstract (Fun a b) 97 | = Fun <$> abstract a <*> abstract b 98 | abstract (Forall sc) 99 | = Forall <$> abstractScope sc 100 | 101 | forallHelper :: String -> Type -> Type 102 | forallHelper x b = Forall (scope [x] b) -------------------------------------------------------------------------------- /src/Record/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Record.Core.Program where 4 | 5 | import Data.List (intercalate) 6 | 7 | import Parens 8 | import Plicity 9 | import Record.Core.ConSig 10 | import Record.Core.Term 11 | 12 | 13 | 14 | -- Term Declarations 15 | 16 | data TermDeclaration 17 | = TermDeclaration String Term Term 18 | | WhereDeclaration String Term [([Plicity],([Pattern],[String],Term))] 19 | 20 | instance Show TermDeclaration where 21 | show (TermDeclaration n ty def) 22 | = "let " ++ n ++ " : " ++ show ty ++ " = " ++ show def ++ " end" 23 | show (WhereDeclaration n ty preclauses) 24 | = "let " ++ n ++ " : " ++ show ty ++ " where " 25 | ++ intercalate " | " (map showPreclause preclauses) 26 | where 27 | showPreclause :: ([Plicity],([Pattern],[String],Term)) -> String 28 | showPreclause (plics,(ps,_,b)) 29 | = intercalate " || " (map showPattern (zip plics ps)) ++ " -> " ++ show b 30 | 31 | showPattern :: (Plicity,Pattern) -> String 32 | showPattern (Expl,p) = parenthesize (Just ExplConPatArg) p 33 | showPattern (Impl,p) = parenthesize (Just ImplConPatArg) p 34 | 35 | 36 | 37 | -- Type Declarations 38 | 39 | data TypeDeclaration 40 | = TypeDeclaration String [DeclArg] [(String,ConSig Term)] 41 | 42 | instance Show TypeDeclaration where 43 | show (TypeDeclaration tycon tyargs []) 44 | = "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 45 | show (TypeDeclaration tycon tyargs alts) 46 | = "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " where" 47 | ++ concat [ "\n" ++ c ++ " : " ++ showConSig (Var . Name) sig | (c,sig) <- alts ] 48 | ++ "\nend" 49 | 50 | 51 | 52 | -- Programs 53 | 54 | data Statement 55 | = TyDecl TypeDeclaration 56 | | TmDecl TermDeclaration 57 | 58 | instance Show Statement where 59 | show (TyDecl td) = show td 60 | show (TmDecl td) = show td 61 | 62 | 63 | data HidingUsing 64 | = Hiding [String] 65 | | Using [String] 66 | 67 | data OpenSettings 68 | = OpenSettings 69 | { openModule :: String 70 | , openAs :: Maybe String 71 | , openHidingUsing :: Maybe HidingUsing 72 | , openRenaming :: [(String,String)] 73 | } 74 | 75 | instance Show OpenSettings where 76 | show (OpenSettings m a hu r) 77 | = m ++ a' ++ hu' ++ r' 78 | where 79 | a' = case a of 80 | Nothing -> "" 81 | Just m' -> " as " ++ m' 82 | hu' = case hu of 83 | Nothing -> "" 84 | Just (Hiding ns) -> " hiding (" ++ intercalate "," ns ++ ")" 85 | Just (Using ns) -> " using (" ++ intercalate "," ns ++ ")" 86 | r' = case r of 87 | [] -> "" 88 | _ -> " renaming (" ++ intercalate ", " [ n ++ " to " ++ n' | (n,n') <- r ] ++ ")" 89 | 90 | data Module 91 | = Module String [OpenSettings] [Statement] 92 | 93 | instance Show Module where 94 | show (Module n [] stmts) 95 | = "module " ++ n ++ " where\n\n" ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 96 | show (Module n settings stmts) 97 | = "module " ++ n ++ " opening " ++ intercalate " | " (map show settings) 98 | ++ " where\n\n" ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 99 | 100 | newtype Program = Program [Module] 101 | 102 | instance Show Program where 103 | show (Program stmts) = intercalate "\n\n" (map show stmts) -------------------------------------------------------------------------------- /src/Modular/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Modular.Core.Program where 4 | 5 | import Data.List (intercalate) 6 | 7 | import Parens 8 | import Plicity 9 | import Modular.Core.ConSig 10 | import Modular.Core.Term 11 | 12 | 13 | 14 | -- Term Declarations 15 | 16 | data TermDeclaration 17 | = TermDeclaration String Term Term 18 | | WhereDeclaration String Term [([Plicity],([Pattern],[String],Term))] 19 | 20 | instance Show TermDeclaration where 21 | show (TermDeclaration n ty def) 22 | = "let " ++ n ++ " : " ++ show ty ++ " = " ++ show def ++ " end" 23 | show (WhereDeclaration n ty preclauses) 24 | = "let " ++ n ++ " : " ++ show ty ++ " where " 25 | ++ intercalate " | " (map showPreclause preclauses) 26 | where 27 | showPreclause :: ([Plicity],([Pattern],[String],Term)) -> String 28 | showPreclause (plics,(ps,_,b)) 29 | = intercalate " || " (map showPattern (zip plics ps)) ++ " -> " ++ show b 30 | 31 | showPattern :: (Plicity,Pattern) -> String 32 | showPattern (Expl,p) = parenthesize (Just ExplConPatArg) p 33 | showPattern (Impl,p) = parenthesize (Just ImplConPatArg) p 34 | 35 | 36 | 37 | -- Type Declarations 38 | 39 | data TypeDeclaration 40 | = TypeDeclaration String [DeclArg] [(String,ConSig Term)] 41 | 42 | instance Show TypeDeclaration where 43 | show (TypeDeclaration tycon tyargs []) 44 | = "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 45 | show (TypeDeclaration tycon tyargs alts) 46 | = "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " where" 47 | ++ concat [ "\n" ++ c ++ " : " ++ showConSig (Var . Name) sig | (c,sig) <- alts ] 48 | ++ "\nend" 49 | 50 | 51 | 52 | -- Programs 53 | 54 | data Statement 55 | = TyDecl TypeDeclaration 56 | | TmDecl TermDeclaration 57 | 58 | instance Show Statement where 59 | show (TyDecl td) = show td 60 | show (TmDecl td) = show td 61 | 62 | 63 | data HidingUsing 64 | = Hiding [String] 65 | | Using [String] 66 | 67 | data OpenSettings 68 | = OpenSettings 69 | { openModule :: String 70 | , openAs :: Maybe String 71 | , openHidingUsing :: Maybe HidingUsing 72 | , openRenaming :: [(String,String)] 73 | } 74 | 75 | instance Show OpenSettings where 76 | show (OpenSettings m a hu r) 77 | = m ++ a' ++ hu' ++ r' 78 | where 79 | a' = case a of 80 | Nothing -> "" 81 | Just m' -> " as " ++ m' 82 | hu' = case hu of 83 | Nothing -> "" 84 | Just (Hiding ns) -> " hiding (" ++ intercalate "," ns ++ ")" 85 | Just (Using ns) -> " using (" ++ intercalate "," ns ++ ")" 86 | r' = case r of 87 | [] -> "" 88 | _ -> " renaming (" ++ intercalate ", " [ n ++ " to " ++ n' | (n,n') <- r ] ++ ")" 89 | 90 | data Module 91 | = Module String [OpenSettings] [Statement] 92 | 93 | instance Show Module where 94 | show (Module n [] stmts) 95 | = "module " ++ n ++ " where\n\n" ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 96 | show (Module n settings stmts) 97 | = "module " ++ n ++ " opening " ++ intercalate " | " (map show settings) 98 | ++ " where\n\n" ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 99 | 100 | newtype Program = Program [Module] 101 | 102 | instance Show Program where 103 | show (Program stmts) = intercalate "\n\n" (map show stmts) -------------------------------------------------------------------------------- /src/Record/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module Record.Core.Evaluation where 7 | 8 | import Control.Monad.Except 9 | 10 | import Env 11 | import Eval 12 | import Plicity 13 | import Scope 14 | import Record.Core.Term 15 | 16 | 17 | 18 | 19 | -- 20 | -- NOTE 21 | -- 22 | -- Plicity mismatches should never occur in evaluable code, so they throw 23 | -- actual Haskell errors, not internal language errors. 24 | -- 25 | 26 | 27 | -- Pattern Matching 28 | 29 | matchPattern :: Pattern -> Term -> Maybe [Term] 30 | matchPattern (VarPat _) v = Just [v] 31 | matchPattern (ConPat c ps) (Con c' as) | c == c' 32 | = matchPatterns ps as 33 | matchPattern (AssertionPat _) _ = Just [] 34 | matchPattern _ _ = Nothing 35 | 36 | matchPatterns :: [(Plicity,Pattern)] -> [(Plicity,Term)] -> Maybe [Term] 37 | matchPatterns [] [] 38 | = Just [] 39 | matchPatterns ((plic,p):ps) ((plic',m):ms) 40 | | plic == plic' 41 | = do vs <- matchPattern p m 42 | vs' <- matchPatterns ps ms 43 | return $ vs ++ vs' 44 | | otherwise 45 | = error "Mismatching plicity in pattern match." 46 | matchPatterns _ _ 47 | = Nothing 48 | 49 | matchClauses :: [Clause] -> [(Plicity,Term)] -> Maybe Term 50 | matchClauses [] _ = Nothing 51 | matchClauses (Clause psc sc:cs) ms 52 | = case matchPatterns [ (Expl,p) | p <- descope Name psc ] ms of 53 | Nothing -> matchClauses cs ms 54 | Just vs -> Just (instantiate sc (removeByDummies (names psc) vs)) 55 | 56 | 57 | 58 | -- Standard Eager Evaluation 59 | 60 | instance Eval (Environment (String,String) Term) Term where 61 | eval (Meta i) 62 | = return $ Meta i 63 | eval (Var x) 64 | = return $ Var x 65 | eval (DottedVar mdl var) 66 | = do env <- environment 67 | case lookup (mdl,var) env of 68 | Nothing -> throwError $ "Unknown constant/defined term: " ++ show (DottedVar mdl var) 69 | Just m -> eval m 70 | eval (Ann m _) 71 | = eval m 72 | eval Type 73 | = return Type 74 | eval (Fun plic a sc) 75 | = return $ Fun plic a sc 76 | eval (Lam plic sc) 77 | = return $ Lam plic sc 78 | eval (App plic f a) 79 | = do ef <- eval f 80 | ea <- eval a 81 | case ef of 82 | Lam plic' sc 83 | | plic == plic' -> eval (instantiate sc [ea]) 84 | | otherwise -> error "Mismatching plicity in function application." 85 | _ -> return $ App plic ef ea 86 | eval (Con c as) 87 | = do eas <- forM as $ \(plic,a) -> 88 | do a' <- eval a 89 | return (plic,a') 90 | return $ Con c eas 91 | eval (Case ms mot cs) 92 | = do ems <- mapM eval ms 93 | case matchClauses cs [ (Expl,em) | em <- ems ] of 94 | Nothing -> if any (\p -> case p of { (Con _ _) -> False ; _ -> True }) ems 95 | then return (Case ms mot cs) 96 | else throwError $ "Incomplete pattern match: " ++ show (Case ms mot cs) 97 | Just b -> eval b 98 | eval (RecordType tele) 99 | = return $ RecordType tele 100 | eval (RecordCon fields) 101 | = RecordCon <$> sequenceA [ (,) x <$> eval m | (x,m) <- fields ] 102 | eval (RecordDot m x) 103 | = do em <- eval m 104 | case em of 105 | RecordCon fields -> case lookup x fields of 106 | Nothing -> throwError $ "Unknown field '" ++ x ++ "' in record " ++ show (RecordCon fields) 107 | Just m' -> return m' 108 | m' -> return $ RecordDot m' x -------------------------------------------------------------------------------- /src/OpenDefs/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module OpenDefs.Core.Evaluation where 7 | 8 | import Control.Monad.Except 9 | 10 | import Env 11 | import Eval 12 | import Plicity 13 | import Scope 14 | import OpenDefs.Core.Term 15 | 16 | 17 | 18 | 19 | -- 20 | -- NOTE 21 | -- 22 | -- Plicity mismatches should never occur in evaluable code, so they throw 23 | -- actual Haskell errors, not internal language errors. 24 | -- 25 | 26 | 27 | -- Pattern Matching 28 | 29 | matchPattern :: Pattern -> Term -> Maybe [Term] 30 | matchPattern (VarPat _) v = Just [v] 31 | matchPattern (ConPat c ps) (Con c' as) | c == c' 32 | = matchPatterns ps as 33 | matchPattern (AssertionPat _) _ = Just [] 34 | matchPattern _ _ = Nothing 35 | 36 | matchPatterns :: [(Plicity,Pattern)] -> [(Plicity,Term)] -> Maybe [Term] 37 | matchPatterns [] [] 38 | = Just [] 39 | matchPatterns ((plic,p):ps) ((plic',m):ms) 40 | | plic == plic' 41 | = do vs <- matchPattern p m 42 | vs' <- matchPatterns ps ms 43 | return $ vs ++ vs' 44 | | otherwise 45 | = error "Mismatching plicity in pattern match." 46 | matchPatterns _ _ 47 | = Nothing 48 | 49 | matchClauses :: [Clause] -> [(Plicity,Term)] -> Maybe Term 50 | matchClauses [] _ = Nothing 51 | matchClauses (Clause psc sc:cs) ms 52 | = case matchPatterns [ (Expl,p) | p <- descope Name psc ] ms of 53 | Nothing -> matchClauses cs ms 54 | Just vs -> Just (instantiate sc (removeByDummies (names psc) vs)) 55 | 56 | 57 | 58 | -- Standard Eager Evaluation 59 | 60 | instance Eval (Environment (String,String) Term) Term where 61 | eval (Meta i) 62 | = return $ Meta i 63 | eval (Var x) 64 | = return $ Var x 65 | eval (DottedVar mdl var) 66 | = do env <- environment 67 | case lookup (mdl,var) env of 68 | Nothing -> throwError $ "Unknown constant/defined term: " ++ show (DottedVar mdl var) 69 | Just m -> eval m 70 | eval (AbsoluteDottedVar mdl var) 71 | = do env <- environment 72 | case lookup (mdl,var) env of 73 | Nothing -> throwError $ "Unknown constant/defined term: " ++ show (AbsoluteDottedVar mdl var) 74 | Just m -> eval m 75 | eval (Ann m _) 76 | = eval m 77 | eval Type 78 | = return Type 79 | eval (Fun plic a sc) 80 | = return $ Fun plic a sc 81 | eval (Lam plic sc) 82 | = return $ Lam plic sc 83 | eval (App plic f a) 84 | = do ef <- eval f 85 | ea <- eval a 86 | case ef of 87 | Lam plic' sc 88 | | plic == plic' -> eval (instantiate sc [ea]) 89 | | otherwise -> error "Mismatching plicity in function application." 90 | _ -> return $ App plic ef ea 91 | eval (Con c as) 92 | = do eas <- forM as $ \(plic,a) -> 93 | do a' <- eval a 94 | return (plic,a') 95 | return $ Con c eas 96 | eval (Case ms mot cs) 97 | = do ems <- mapM eval ms 98 | case matchClauses cs [ (Expl,em) | em <- ems ] of 99 | Nothing -> if any (\p -> case p of { (Con _ _) -> False ; _ -> True }) ems 100 | then return (Case ms mot cs) 101 | else throwError $ "Incomplete pattern match: " ++ show (Case ms mot cs) 102 | Just b -> eval b 103 | eval (RecordType tele) 104 | = return $ RecordType tele 105 | eval (RecordCon fields) 106 | = RecordCon <$> sequenceA [ (,) x <$> eval m | (x,m) <- fields ] 107 | eval (RecordDot m x) 108 | = do em <- eval m 109 | case em of 110 | RecordCon fields -> case lookup x fields of 111 | Nothing -> throwError $ "Unknown field '" ++ x ++ "' in record " ++ show (RecordCon fields) 112 | Just m' -> return m' 113 | m' -> return $ RecordDot m' x -------------------------------------------------------------------------------- /src/Quasiquote/Core/Evaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module Quasiquote.Core.Evaluation where 7 | 8 | import Control.Monad.Except 9 | 10 | import Env 11 | import Eval 12 | import Plicity 13 | import Scope 14 | import Quasiquote.Core.Term 15 | 16 | 17 | 18 | 19 | -- 20 | -- NOTE 21 | -- 22 | -- Plicity mismatches should never occur in evaluable code, so they throw 23 | -- actual Haskell errors, not internal language errors. 24 | -- 25 | 26 | 27 | -- Pattern Matching 28 | 29 | matchPattern :: Pattern -> Term -> Maybe [Term] 30 | matchPattern (VarPat _) v = Just [v] 31 | matchPattern (ConPat c ps) (Con c' as) | c == c' 32 | = matchPatterns ps as 33 | matchPattern (AssertionPat _) _ = Just [] 34 | matchPattern _ _ = Nothing 35 | 36 | matchPatterns :: [(Plicity,Pattern)] -> [(Plicity,Term)] -> Maybe [Term] 37 | matchPatterns [] [] 38 | = Just [] 39 | matchPatterns ((plic,p):ps) ((plic',m):ms) 40 | | plic == plic' 41 | = do vs <- matchPattern p m 42 | vs' <- matchPatterns ps ms 43 | return $ vs ++ vs' 44 | | otherwise 45 | = error "Mismatching plicity in pattern match." 46 | matchPatterns _ _ 47 | = Nothing 48 | 49 | matchClauses :: [Clause] -> [(Plicity,Term)] -> Maybe Term 50 | matchClauses [] _ = Nothing 51 | matchClauses (Clause psc sc:cs) ms 52 | = case matchPatterns [ (Expl,p) | p <- descope Name psc ] ms of 53 | Nothing -> matchClauses cs ms 54 | Just vs -> Just (instantiate sc (removeByDummies (names psc) vs)) 55 | 56 | 57 | 58 | -- Standard Eager Evaluation 59 | 60 | instance Eval (Environment (String,String) Term) Term where 61 | eval (Meta i) 62 | = return $ Meta i 63 | eval (Var x) 64 | = return $ Var x 65 | eval (DottedVar mdl var) 66 | = do env <- environment 67 | case lookup (mdl,var) env of 68 | Nothing -> throwError $ "Unknown constant/defined term: " ++ show (DottedVar mdl var) 69 | Just m -> eval m 70 | eval (AbsoluteDottedVar mdl var) 71 | = do env <- environment 72 | case lookup (mdl,var) env of 73 | Nothing -> throwError $ "Unknown constant/defined term: " ++ show (AbsoluteDottedVar mdl var) 74 | Just m -> eval m 75 | eval (Ann m _) 76 | = eval m 77 | eval Type 78 | = return Type 79 | eval (Fun plic a sc) 80 | = return $ Fun plic a sc 81 | eval (Lam plic sc) 82 | = return $ Lam plic sc 83 | eval (App plic f a) 84 | = do ef <- eval f 85 | ea <- eval a 86 | case ef of 87 | Lam plic' sc 88 | | plic == plic' -> eval (instantiate sc [ea]) 89 | | otherwise -> error "Mismatching plicity in function application." 90 | _ -> return $ App plic ef ea 91 | eval (Con c as) 92 | = do eas <- forM as $ \(plic,a) -> 93 | do a' <- eval a 94 | return (plic,a') 95 | return $ Con c eas 96 | eval (Case ms mot cs) 97 | = do ems <- mapM eval ms 98 | case matchClauses cs [ (Expl,em) | em <- ems ] of 99 | Nothing -> if any (\p -> case p of { (Con _ _) -> False ; _ -> True }) ems 100 | then return (Case ms mot cs) 101 | else throwError $ "Incomplete pattern match: " ++ show (Case ms mot cs) 102 | Just b -> eval b 103 | eval (RecordType tele) 104 | = return $ RecordType tele 105 | eval (RecordCon fields) 106 | = RecordCon <$> sequenceA [ (,) x <$> eval m | (x,m) <- fields ] 107 | eval (RecordDot m x) 108 | = do em <- eval m 109 | case em of 110 | RecordCon fields -> case lookup x fields of 111 | Nothing -> throwError $ "Unknown field '" ++ x ++ "' in record " ++ show (RecordCon fields) 112 | Just m' -> return m' 113 | m' -> return $ RecordDot m' x 114 | eval (Quoted a) 115 | = Quoted <$> eval a 116 | eval (Quote m) 117 | = return $ Quote m 118 | eval (Unquote m sc) 119 | = do em <- eval m 120 | case em of 121 | Quote m' 122 | -> eval (instantiate sc [m']) 123 | _ -> return $ Unquote em sc -------------------------------------------------------------------------------- /src/OpenDefs/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module OpenDefs.Core.Program where 4 | 5 | import Data.List (intercalate) 6 | 7 | import Parens 8 | import Plicity 9 | import OpenDefs.Core.ConSig 10 | import OpenDefs.Core.Term 11 | 12 | 13 | 14 | -- Term Declarations 15 | 16 | data TermDeclaration 17 | = TermDeclaration String Term Term 18 | | WhereDeclaration String Term [([Plicity],([Pattern],[String],Term))] 19 | | LetFamilyDeclaration String [DeclArg] Term 20 | | LetInstanceDeclaration (Either String (String,String)) [([Plicity],([Pattern],[String],Term))] 21 | 22 | showPreclause :: ([Plicity],([Pattern],[String],Term)) -> String 23 | showPreclause (plics,(ps,_,b)) 24 | = intercalate " || " (map showPattern (zip plics ps)) ++ " -> " ++ show b 25 | 26 | showPattern :: (Plicity,Pattern) -> String 27 | showPattern (Expl,p) = parenthesize (Just ExplConPatArg) p 28 | showPattern (Impl,p) = parenthesize (Just ImplConPatArg) p 29 | 30 | instance Show TermDeclaration where 31 | show (TermDeclaration n ty def) 32 | = "let " ++ n ++ " : " ++ show ty ++ " = " ++ show def ++ " end" 33 | show (WhereDeclaration n ty preclauses) 34 | = "let " ++ n ++ " : " ++ show ty ++ " where " 35 | ++ intercalate " | " (map showPreclause preclauses) 36 | show (LetFamilyDeclaration n args ty) 37 | = "let family " ++ n ++ " " ++ unwords (map show args) ++ " : " ++ show ty ++ " end" 38 | show (LetInstanceDeclaration n preclauses) 39 | = "let instance " ++ show n ++ " where " 40 | ++ intercalate " | " (map showPreclause preclauses) 41 | 42 | 43 | 44 | -- Type Declarations 45 | 46 | data TypeDeclaration 47 | = TypeDeclaration String [DeclArg] [(String,ConSig Term)] 48 | | DataFamilyDeclaration String [DeclArg] 49 | | DataInstanceDeclaration Constructor [(String,ConSig Term)] 50 | 51 | instance Show TypeDeclaration where 52 | show (TypeDeclaration tycon tyargs []) 53 | = "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 54 | show (TypeDeclaration tycon tyargs alts) 55 | = "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " where" 56 | ++ concat [ "\n" ++ c ++ " : " ++ showConSig (Var . Name) sig | (c,sig) <- alts ] 57 | ++ "\nend" 58 | show (DataFamilyDeclaration tycon tyargs) 59 | = "data family " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 60 | show (DataInstanceDeclaration tycon alts) 61 | = "data instance " ++ show tycon ++ " where" 62 | ++ concat [ "\n" ++ c ++ " : " ++ showConSig (Var . Name) sig | (c,sig) <- alts ] 63 | ++ "\nend" 64 | 65 | 66 | 67 | -- Programs 68 | 69 | data Statement 70 | = TyDecl TypeDeclaration 71 | | TmDecl TermDeclaration 72 | 73 | instance Show Statement where 74 | show (TyDecl td) = show td 75 | show (TmDecl td) = show td 76 | 77 | 78 | data HidingUsing 79 | = Hiding [String] 80 | | Using [String] 81 | 82 | data OpenSettings 83 | = OpenSettings 84 | { openModule :: String 85 | , openAs :: Maybe String 86 | , openHidingUsing :: Maybe HidingUsing 87 | , openRenaming :: [(String,String)] 88 | } 89 | 90 | instance Show OpenSettings where 91 | show (OpenSettings m a hu r) 92 | = m ++ a' ++ hu' ++ r' 93 | where 94 | a' = case a of 95 | Nothing -> "" 96 | Just m' -> " as " ++ m' 97 | hu' = case hu of 98 | Nothing -> "" 99 | Just (Hiding ns) -> " hiding (" ++ intercalate "," ns ++ ")" 100 | Just (Using ns) -> " using (" ++ intercalate "," ns ++ ")" 101 | r' = case r of 102 | [] -> "" 103 | _ -> " renaming (" ++ intercalate ", " [ n ++ " to " ++ n' | (n,n') <- r ] ++ ")" 104 | 105 | data Module 106 | = Module String [OpenSettings] [Statement] 107 | 108 | instance Show Module where 109 | show (Module n [] stmts) 110 | = "module " ++ n ++ " where\n\n" ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 111 | show (Module n settings stmts) 112 | = "module " ++ n ++ " opening " ++ intercalate " | " (map show settings) 113 | ++ " where\n\n" ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 114 | 115 | newtype Program = Program [Module] 116 | 117 | instance Show Program where 118 | show (Program stmts) = intercalate "\n\n" (map show stmts) -------------------------------------------------------------------------------- /src/Quasiquote/Core/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Quasiquote.Core.Program where 4 | 5 | import Data.List (intercalate) 6 | 7 | import Parens 8 | import Plicity 9 | import Quasiquote.Core.ConSig 10 | import Quasiquote.Core.Term 11 | 12 | 13 | 14 | -- Term Declarations 15 | 16 | data TermDeclaration 17 | = TermDeclaration String Term Term 18 | | WhereDeclaration String Term [([Plicity],([Pattern],[String],Term))] 19 | | LetFamilyDeclaration String [DeclArg] Term 20 | | LetInstanceDeclaration (Either String (String,String)) [([Plicity],([Pattern],[String],Term))] 21 | 22 | showPreclause :: ([Plicity],([Pattern],[String],Term)) -> String 23 | showPreclause (plics,(ps,_,b)) 24 | = intercalate " || " (map showPattern (zip plics ps)) ++ " -> " ++ show b 25 | 26 | showPattern :: (Plicity,Pattern) -> String 27 | showPattern (Expl,p) = parenthesize (Just ExplConPatArg) p 28 | showPattern (Impl,p) = parenthesize (Just ImplConPatArg) p 29 | 30 | instance Show TermDeclaration where 31 | show (TermDeclaration n ty def) 32 | = "let " ++ n ++ " : " ++ show ty ++ " = " ++ show def ++ " end" 33 | show (WhereDeclaration n ty preclauses) 34 | = "let " ++ n ++ " : " ++ show ty ++ " where " 35 | ++ intercalate " | " (map showPreclause preclauses) 36 | show (LetFamilyDeclaration n args ty) 37 | = "let family " ++ n ++ " " ++ unwords (map show args) ++ " : " ++ show ty ++ " end" 38 | show (LetInstanceDeclaration n preclauses) 39 | = "let instance " ++ show n ++ " where " 40 | ++ intercalate " | " (map showPreclause preclauses) 41 | 42 | 43 | 44 | -- Type Declarations 45 | 46 | data TypeDeclaration 47 | = TypeDeclaration String [DeclArg] [(String,ConSig Term)] 48 | | DataFamilyDeclaration String [DeclArg] 49 | | DataInstanceDeclaration Constructor [(String,ConSig Term)] 50 | 51 | instance Show TypeDeclaration where 52 | show (TypeDeclaration tycon tyargs []) 53 | = "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 54 | show (TypeDeclaration tycon tyargs alts) 55 | = "data " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " where" 56 | ++ concat [ "\n" ++ c ++ " : " ++ showConSig (Var . Name) sig | (c,sig) <- alts ] 57 | ++ "\nend" 58 | show (DataFamilyDeclaration tycon tyargs) 59 | = "data family " ++ tycon ++ concat (map (\x -> " " ++ show x) tyargs) ++ " end" 60 | show (DataInstanceDeclaration tycon alts) 61 | = "data instance " ++ show tycon ++ " where" 62 | ++ concat [ "\n" ++ c ++ " : " ++ showConSig (Var . Name) sig | (c,sig) <- alts ] 63 | ++ "\nend" 64 | 65 | 66 | 67 | -- Programs 68 | 69 | data Statement 70 | = TyDecl TypeDeclaration 71 | | TmDecl TermDeclaration 72 | 73 | instance Show Statement where 74 | show (TyDecl td) = show td 75 | show (TmDecl td) = show td 76 | 77 | 78 | data HidingUsing 79 | = Hiding [String] 80 | | Using [String] 81 | 82 | data OpenSettings 83 | = OpenSettings 84 | { openModule :: String 85 | , openAs :: Maybe String 86 | , openHidingUsing :: Maybe HidingUsing 87 | , openRenaming :: [(String,String)] 88 | } 89 | 90 | instance Show OpenSettings where 91 | show (OpenSettings m a hu r) 92 | = m ++ a' ++ hu' ++ r' 93 | where 94 | a' = case a of 95 | Nothing -> "" 96 | Just m' -> " as " ++ m' 97 | hu' = case hu of 98 | Nothing -> "" 99 | Just (Hiding ns) -> " hiding (" ++ intercalate "," ns ++ ")" 100 | Just (Using ns) -> " using (" ++ intercalate "," ns ++ ")" 101 | r' = case r of 102 | [] -> "" 103 | _ -> " renaming (" ++ intercalate ", " [ n ++ " to " ++ n' | (n,n') <- r ] ++ ")" 104 | 105 | data Module 106 | = Module String [OpenSettings] [Statement] 107 | 108 | instance Show Module where 109 | show (Module n [] stmts) 110 | = "module " ++ n ++ " where\n\n" ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 111 | show (Module n settings stmts) 112 | = "module " ++ n ++ " opening " ++ intercalate " | " (map show settings) 113 | ++ " where\n\n" ++ intercalate "\n\n" (map show stmts) ++ "\n\nend" 114 | 115 | newtype Program = Program [Module] 116 | 117 | instance Show Program where 118 | show (Program stmts) = intercalate "\n\n" (map show stmts) -------------------------------------------------------------------------------- /src/Dependent/Core/Term.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | 7 | module Dependent.Core.Term where 8 | 9 | import Data.List (intercalate) 10 | 11 | import Parens 12 | import Scope 13 | 14 | 15 | 16 | -- Used in multiple places 17 | 18 | data DeclArg = DeclArg String Term 19 | 20 | instance Show DeclArg where 21 | show (DeclArg x t) = "(" ++ x ++ " : " ++ show t ++ ")" 22 | 23 | 24 | 25 | -- Terms 26 | 27 | data Variable 28 | = Name String 29 | | Generated String Int 30 | 31 | instance Eq Variable where 32 | Name x == Name y = x == y 33 | Generated _ i == Generated _ j = i == j 34 | _ == _ = False 35 | 36 | data Term 37 | = Meta Int 38 | | Var Variable 39 | | Ann Term Term 40 | | Type 41 | | Fun Term (Scope Term Term) 42 | | Lam (Scope Term Term) 43 | | App Term Term 44 | | Con String [Term] 45 | | Case [Term] CaseMotive [Clause] 46 | 47 | data CaseMotive 48 | = CaseMotiveNil Term 49 | | CaseMotiveCons Term (Scope Term CaseMotive) 50 | 51 | data Clause 52 | = Clause (Scope Variable [Pattern]) (Scope Term Term) 53 | 54 | data Pattern 55 | = VarPat Variable 56 | | ConPat String [Pattern] 57 | | AssertionPat Term 58 | 59 | 60 | 61 | 62 | -- Case Motive Length 63 | 64 | caseMotiveLength :: CaseMotive -> Int 65 | caseMotiveLength (CaseMotiveNil _) = 0 66 | caseMotiveLength (CaseMotiveCons _ sc) 67 | = 1 + caseMotiveLength (descope (Var . Name) sc) 68 | 69 | 70 | 71 | 72 | -- Show Instances 73 | 74 | instance Show Variable where 75 | show (Name x) = x 76 | show (Generated x _) = x 77 | 78 | data PatternParenLoc = ConPatArg 79 | deriving (Eq) 80 | 81 | instance ParenLoc Pattern where 82 | type Loc Pattern = PatternParenLoc 83 | parenLoc (VarPat _) = [ConPatArg] 84 | parenLoc (ConPat _ _) = [] 85 | parenLoc (AssertionPat _) = [ConPatArg] 86 | 87 | instance ParenRec Pattern where 88 | parenRec (VarPat x) 89 | = show x 90 | parenRec (ConPat c []) 91 | = c 92 | parenRec (ConPat c ps) 93 | = c ++ " " ++ unwords (map (parenthesize (Just ConPatArg)) ps) 94 | parenRec (AssertionPat m) 95 | = "." ++ parenthesize (Just AssertionPatArg) m 96 | 97 | instance Show Pattern where 98 | show p = parenthesize Nothing p 99 | 100 | 101 | 102 | data TermParenLoc 103 | = RootTerm 104 | | AnnLeft | AnnRight 105 | | FunArg | FunRet 106 | | LamBody | AppLeft | AppRight 107 | | ConArg | AssertionPatArg 108 | deriving (Eq) 109 | 110 | instance ParenLoc Term where 111 | type Loc Term = TermParenLoc 112 | parenLoc (Meta _) 113 | = [AnnLeft,FunArg,FunRet,LamBody,AppLeft,AppRight,ConArg,AssertionPatArg] 114 | parenLoc (Var _) 115 | = [AnnLeft,FunArg,FunRet,LamBody,AppLeft,AppRight,ConArg,AssertionPatArg] 116 | parenLoc (Ann _ _) 117 | = [FunArg,FunRet,LamBody] 118 | parenLoc Type 119 | = [AnnLeft,FunArg,FunRet,LamBody,AppLeft,AppRight,ConArg,AssertionPatArg] 120 | parenLoc (Fun _ _) 121 | = [FunArg,FunRet,LamBody] 122 | parenLoc (Lam _) 123 | = [FunArg,FunRet,LamBody] 124 | parenLoc (App _ _) 125 | = [FunArg,FunRet,AnnLeft,LamBody,AppLeft] 126 | parenLoc (Con _ []) 127 | = [FunArg,FunRet,AnnLeft,LamBody,AppLeft,AppRight,ConArg,AssertionPatArg] 128 | parenLoc (Con _ _) 129 | = [FunArg,FunRet,AnnLeft,LamBody] 130 | parenLoc (Case _ _ _) 131 | = [FunArg,FunRet,LamBody] 132 | 133 | instance ParenRec Term where 134 | parenRec (Meta i) 135 | = "?" ++ show i 136 | parenRec (Var x) 137 | = show x 138 | parenRec (Ann m ty) 139 | = parenthesize (Just AnnLeft) m ++ " : " ++ parenthesize (Just AnnRight) ty 140 | parenRec Type 141 | = "Type" 142 | parenRec (Fun a sc) 143 | = "(" ++ unwords (names sc) ++ " : " ++ parenthesize (Just FunArg) a 144 | ++ ") -> " ++ parenthesize (Just FunRet) 145 | (descope (Var . Name) sc) 146 | parenRec (Lam sc) 147 | = "\\" ++ unwords (names sc) 148 | ++ " -> " ++ parenthesize (Just LamBody) 149 | (descope (Var . Name) sc) 150 | parenRec (App f a) 151 | = parenthesize (Just AppLeft) f ++ " " ++ parenthesize (Just AppRight) a 152 | parenRec (Con c []) 153 | = c 154 | parenRec (Con c as) 155 | = c ++ " " ++ intercalate " " (map (parenthesize (Just ConArg)) as) 156 | parenRec (Case ms mot cs) 157 | = "case " ++ intercalate " || " (map (parenthesize Nothing) ms) 158 | ++ " motive " ++ show mot 159 | ++ " of " ++ intercalate " | " (map auxClause cs) ++ " end" 160 | where 161 | auxClause (Clause psc sc) 162 | = intercalate " || " (map show (descope Name psc)) 163 | ++ " -> " ++ parenthesize Nothing 164 | (descope (Var . Name) sc) 165 | 166 | 167 | 168 | instance Show Term where 169 | show t = parenthesize Nothing t 170 | 171 | 172 | 173 | instance Show CaseMotive where 174 | show (CaseMotiveNil ret) = show ret 175 | show (CaseMotiveCons arg sc) 176 | = "(" ++ unwords (names sc) ++ " : " ++ show arg ++ ") || " 177 | ++ show (descope (Var . Name) sc) -------------------------------------------------------------------------------- /src/Simple/Unification/Elaboration.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Simple.Unification.Elaboration where 4 | 5 | import Control.Applicative ((<$>)) 6 | import Control.Monad.Except 7 | import Control.Monad.State 8 | 9 | import Scope 10 | import TypeChecker (extendDefinitions) 11 | 12 | import Simple.Core.Abstraction 13 | import Simple.Core.Term 14 | import Simple.Core.Type 15 | import Simple.Core.Program 16 | 17 | import Simple.Unification.TypeChecking 18 | 19 | 20 | data ElabState 21 | = ElabState 22 | { elabSig :: Signature 23 | , elabDefs :: Definitions 24 | , elabCtx :: Context 25 | , elabNextName :: Int 26 | } 27 | 28 | type Elaborator a = StateT ElabState (Either String) a 29 | 30 | runElaborator :: Elaborator () -> Either String ElabState 31 | runElaborator elab = do (_,p) <- runStateT elab (ElabState (Signature [] []) [] [] 0) 32 | return p 33 | 34 | signature :: Elaborator Signature 35 | signature = elabSig <$> get 36 | 37 | definitions :: Elaborator Definitions 38 | definitions = elabDefs <$> get 39 | 40 | context :: Elaborator Context 41 | context = do elabCtx <$> get 42 | 43 | putSignature :: Signature -> Elaborator () 44 | putSignature sig = do s <- get 45 | put (s { elabSig = sig}) 46 | 47 | putDefinitions :: Definitions -> Elaborator () 48 | putDefinitions defs = do s <- get 49 | put (s { elabDefs = defs}) 50 | 51 | putContext :: Context -> Elaborator () 52 | putContext ctx = do s <- get 53 | put (s { elabCtx = ctx }) 54 | 55 | when' :: TypeChecker a -> Elaborator () -> Elaborator () 56 | when' tc e = do ElabState sig defs ctx i <- get 57 | case runTypeChecker tc sig defs ctx i of 58 | Left _ -> return () 59 | Right _ -> e 60 | 61 | liftTC :: TypeChecker a -> Elaborator a 62 | liftTC tc = do ElabState sig defs ctx i <- get 63 | case runTypeChecker tc sig defs ctx i of 64 | Left e -> throwError e 65 | Right (a,s) -> do s' <- get 66 | put s' { elabNextName = tcNextName s } 67 | return a 68 | 69 | addDeclaration :: String -> Term -> Type -> Elaborator () 70 | addDeclaration n def ty = do defs <- definitions 71 | putDefinitions ((n,def,ty):defs) 72 | 73 | addTypeConstructor :: String -> Elaborator () 74 | addTypeConstructor n = do Signature tycons consigs <- signature 75 | putSignature (Signature (n:tycons) consigs) 76 | 77 | addConstructor :: String -> String -> [Type] -> Elaborator () 78 | addConstructor tycon n args 79 | = do Signature tycons consigs <- signature 80 | let consig = ConSig args (TyCon tycon) 81 | putSignature (Signature tycons ((n,consig):consigs)) 82 | 83 | 84 | 85 | 86 | elabTermDecl :: TermDeclaration -> Elaborator () 87 | elabTermDecl (TermDeclaration n ty def) 88 | = do when' (typeInDefinitions n) 89 | $ throwError ("Term already defined: " ++ n) 90 | liftTC (isType ty) 91 | liftTC (extendDefinitions [(n,def,ty)] (check def ty)) 92 | addDeclaration n def ty 93 | elabTermDecl (WhereDeclaration n ty preclauses) 94 | = case preclauses of 95 | [] -> throwError "Cannot create an empty let-where definition." 96 | [(ps,xs,b)] | all isVarPat ps 97 | -> elabTermDecl (TermDeclaration n ty (helperFold lamHelper xs b)) 98 | (ps0,_,_):_ 99 | -> let clauses = [ clauseHelper ps xs b | (ps,xs,b) <- preclauses ] 100 | in elabTermDecl (TermDeclaration n ty (lambdaAux (\as -> Case as clauses) (length ps0))) 101 | where 102 | isVarPat :: Pattern -> Bool 103 | isVarPat (VarPat _) = True 104 | isVarPat _ = False 105 | 106 | lambdaAux :: ([Term] -> Term) -> Int -> Term 107 | lambdaAux f 0 = f [] 108 | lambdaAux f i = Lam (Scope ["_" ++ show i] $ \[x] -> lambdaAux (f . (x:)) (i-1)) 109 | 110 | 111 | 112 | elabAlt :: String -> String -> [Type] -> Elaborator () 113 | elabAlt tycon n args 114 | = do when' (typeInSignature n) 115 | $ throwError ("Constructor already declared: " ++ n) 116 | liftTC (mapM_ isType args) 117 | addConstructor tycon n args 118 | 119 | elabAlts :: String -> [(String, [Type])] -> Elaborator () 120 | elabAlts _ [] = return () 121 | elabAlts tycon ((n,args):cs) = do elabAlt tycon n args 122 | elabAlts tycon cs 123 | 124 | elabTypeDecl :: TypeDeclaration -> Elaborator () 125 | elabTypeDecl (TypeDeclaration tycon alts) 126 | = do when' (isType (TyCon tycon)) 127 | $ throwError ("Type constructor already declared: " ++ tycon) 128 | addTypeConstructor tycon 129 | elabAlts tycon alts 130 | 131 | elabProgram :: Program -> Elaborator () 132 | elabProgram (Program stmts0) = go stmts0 133 | where 134 | go :: [Statement] -> Elaborator () 135 | go [] = return () 136 | go (TyDecl td:stmts) = do elabTypeDecl td 137 | go stmts 138 | go (TmDecl td:stmts) = do elabTermDecl td 139 | go stmts -------------------------------------------------------------------------------- /src/Dependent/Core/Abstraction.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module Dependent.Core.Abstraction where 7 | 8 | import Control.Applicative 9 | import Control.Monad.Reader 10 | import qualified Control.Monad.State as S 11 | 12 | import Abs 13 | import Scope 14 | import Dependent.Core.ConSig 15 | import Dependent.Core.Term 16 | 17 | 18 | 19 | instance Abstract String Term Clause where 20 | abstract (Clause psc sc) 21 | = Clause <$> abstractScope psc <*> abstractScope sc 22 | 23 | instance Abstract String Variable Clause where 24 | abstract (Clause psc sc) 25 | = Clause <$> abstractScope psc <*> abstractScope sc 26 | 27 | instance Abstract String Term CaseMotive where 28 | abstract (CaseMotiveNil a) 29 | = CaseMotiveNil <$> abstract a 30 | abstract (CaseMotiveCons a sc) 31 | = CaseMotiveCons <$> abstract a <*> abstractScope sc 32 | 33 | instance Abstract String Variable CaseMotive where 34 | abstract (CaseMotiveNil a) 35 | = CaseMotiveNil <$> abstract a 36 | abstract (CaseMotiveCons a sc) 37 | = CaseMotiveCons <$> abstract a <*> abstractScope sc 38 | 39 | instance Abstract String Term Term where 40 | abstract (Meta i) 41 | = return $ Meta i 42 | abstract (Var (Name x)) 43 | = reader $ \e -> 44 | case lookup x e of 45 | Nothing -> Var (Name x) 46 | Just m -> m 47 | abstract (Var (Generated x i)) 48 | = return $ Var (Generated x i) 49 | abstract (Ann m ty) 50 | = Ann <$> abstract m <*> return ty 51 | abstract Type 52 | = return Type 53 | abstract (Fun a sc) 54 | = Fun <$> abstract a <*> abstractScope sc 55 | abstract (Lam sc) 56 | = Lam <$> abstractScope sc 57 | abstract (App f a) 58 | = App <$> abstract f <*> abstract a 59 | abstract (Con c as) 60 | = Con c <$> mapM abstract as 61 | abstract (Case as t cs) 62 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 63 | 64 | instance Abstract String Variable Term where 65 | abstract (Meta i) 66 | = return $ Meta i 67 | abstract (Var (Name x)) 68 | = reader $ \e -> 69 | case lookup x e of 70 | Nothing -> Var (Name x) 71 | Just y -> Var y 72 | abstract (Var (Generated x i)) 73 | = return $ Var (Generated x i) 74 | abstract (Ann m ty) 75 | = Ann <$> abstract m <*> return ty 76 | abstract Type 77 | = return Type 78 | abstract (Fun a sc) 79 | = Fun <$> abstract a <*> abstractScope sc 80 | abstract (Lam sc) 81 | = Lam <$> abstractScope sc 82 | abstract (App f a) 83 | = App <$> abstract f <*> abstract a 84 | abstract (Con c as) 85 | = Con c <$> mapM abstract as 86 | abstract (Case as t cs) 87 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 88 | 89 | instance Abstract String Term Pattern where 90 | abstract (VarPat x) 91 | = return $ VarPat x 92 | abstract (ConPat c ps) 93 | = ConPat c <$> mapM abstract ps 94 | abstract (AssertionPat m) 95 | = AssertionPat <$> abstract m 96 | 97 | instance Abstract String Variable Pattern where 98 | abstract (VarPat (Name x)) 99 | = reader $ \e -> 100 | case lookup x e of 101 | Nothing -> VarPat (Name x) 102 | Just y -> VarPat y 103 | abstract (VarPat (Generated x i)) 104 | = return $ VarPat (Generated x i) 105 | abstract (ConPat c ps) 106 | = ConPat c <$> mapM abstract ps 107 | abstract (AssertionPat m) 108 | = AssertionPat <$> abstract m 109 | 110 | funHelper :: String -> Term -> Term -> Term 111 | funHelper x a b = Fun a (scope [x] b) 112 | 113 | lamHelper :: String -> Term -> Term 114 | lamHelper x b = Lam (scope [x] b) 115 | 116 | clauseHelper :: [Pattern] -> [String] -> Term -> Clause 117 | clauseHelper ps xs b = Clause (scope2 xs cleanedXs cleanedPs) (scope (filter isVar xs) b) 118 | where 119 | cleanedXs = fst (S.runState (mapM cleanXs xs) 0) 120 | 121 | cleanXs :: String -> S.State Int String 122 | cleanXs "_" = do i <- S.get 123 | S.put (i+1) 124 | return $ "$" ++ show i 125 | cleanXs x = return x 126 | 127 | cleanedPs = fst (S.runState (mapM cleanPs ps) 0) 128 | 129 | cleanPs :: Pattern -> S.State Int Pattern 130 | cleanPs (VarPat (Name "_")) 131 | = do i <- S.get 132 | S.put (i+1) 133 | return $ VarPat (Name ("$" ++ show i)) 134 | cleanPs (VarPat (Name n)) 135 | = return $ VarPat (Name n) 136 | cleanPs (VarPat (Generated n i)) 137 | = return $ VarPat (Generated n i) 138 | cleanPs (ConPat c ps) 139 | = ConPat c <$> mapM cleanPs ps 140 | cleanPs (AssertionPat m) 141 | = return $ AssertionPat m 142 | 143 | consMotiveHelper :: String -> Term -> CaseMotive -> CaseMotive 144 | consMotiveHelper x a b = CaseMotiveCons a (scope [x] b) 145 | 146 | instance Abstract String Term (ConSig Term) where 147 | abstract (ConSigNil a) 148 | = ConSigNil <$> abstract a 149 | abstract (ConSigCons a sc) 150 | = ConSigCons <$> abstract a <*> abstractScope sc 151 | 152 | conSigHelper :: [DeclArg] -> Term -> ConSig Term 153 | conSigHelper [] b = ConSigNil b 154 | conSigHelper (DeclArg x a:as) b 155 | = ConSigCons a (scope [x] (conSigHelper as b)) -------------------------------------------------------------------------------- /src/Poly/Unification/Elaboration.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module Poly.Unification.Elaboration where 7 | 8 | import Control.Applicative ((<$>),(<*>)) 9 | import Control.Monad.Except 10 | import Control.Monad.Reader 11 | import Control.Monad.State 12 | 13 | import Abs 14 | import Scope 15 | import TypeChecker (extendDefinitions) 16 | 17 | import Poly.Core.Abstraction 18 | import Poly.Core.Term 19 | import Poly.Core.Type 20 | import Poly.Core.Program 21 | 22 | import Poly.Unification.TypeChecking 23 | 24 | 25 | data ElabState 26 | = ElabState 27 | { elabSig :: Signature 28 | , elabDefs :: Definitions 29 | , elabCtx :: Context 30 | , elabNextName :: Int 31 | } 32 | 33 | type Elaborator a = StateT ElabState (Either String) a 34 | 35 | runElaborator :: Elaborator () -> Either String ElabState 36 | runElaborator elab = do (_,p) <- runStateT elab (ElabState (Signature [] []) [] [] 0) 37 | return p 38 | 39 | signature :: Elaborator Signature 40 | signature = elabSig <$> get 41 | 42 | definitions :: Elaborator Definitions 43 | definitions = elabDefs <$> get 44 | 45 | context :: Elaborator Context 46 | context = elabCtx <$> get 47 | 48 | putSignature :: Signature -> Elaborator () 49 | putSignature sig = do s <- get 50 | put (s { elabSig = sig }) 51 | 52 | putDefinitions :: Definitions -> Elaborator () 53 | putDefinitions defs = do s <- get 54 | put (s { elabDefs = defs }) 55 | 56 | putContext :: Context -> Elaborator () 57 | putContext ctx = do s <- get 58 | put (s { elabCtx = ctx }) 59 | 60 | when' :: TypeChecker a -> Elaborator () -> Elaborator () 61 | when' tc e = do ElabState sig defs ctx i <- get 62 | case runTypeChecker tc sig defs ctx i of 63 | Left _ -> return () 64 | Right _ -> e 65 | 66 | liftTC :: TypeChecker a -> Elaborator a 67 | liftTC tc = do ElabState sig defs ctx i <- get 68 | case runTypeChecker tc sig defs ctx i of 69 | Left e -> throwError e 70 | Right (a,s) -> do s' <- get 71 | put s' { elabNextName = tcNextName s } 72 | return a 73 | 74 | addDeclaration :: String -> Term -> Type -> Elaborator () 75 | addDeclaration n def ty = do defs <- definitions 76 | putDefinitions ((n,def,ty) : defs) 77 | 78 | addTypeConstructor :: String -> Int -> Elaborator () 79 | addTypeConstructor n arity 80 | = do Signature tyconsigs consigs <- signature 81 | putSignature (Signature ((n,TyConSig arity):tyconsigs) consigs) 82 | 83 | addConstructor :: String -> ConSig -> Elaborator () 84 | addConstructor n consig 85 | = do Signature tycons consigs <- signature 86 | putSignature (Signature tycons ((n,consig):consigs)) 87 | 88 | 89 | 90 | elabTermDecl :: TermDeclaration -> Elaborator () 91 | elabTermDecl (TermDeclaration n ty def) 92 | = do when' (typeInDefinitions n) 93 | $ throwError ("Term already defined: " ++ n) 94 | liftTC (isType ty) 95 | liftTC (extendDefinitions [(n,def,ty)] (check def ty)) 96 | addDeclaration n def ty 97 | elabTermDecl (WhereDeclaration n ty preclauses) 98 | = case preclauses of 99 | [] -> throwError "Cannot create an empty let-where definition." 100 | [(ps,xs,b)] | all isVarPat ps 101 | -> elabTermDecl (TermDeclaration n ty (helperFold lamHelper xs b)) 102 | (ps0,_,_):_ 103 | -> let clauses = [ clauseHelper ps xs b | (ps,xs,b) <- preclauses ] 104 | in elabTermDecl (TermDeclaration n ty (lambdaAux (\as -> Case as clauses) (length ps0))) 105 | where 106 | isVarPat :: Pattern -> Bool 107 | isVarPat (VarPat _) = True 108 | isVarPat _ = False 109 | 110 | lambdaAux :: ([Term] -> Term) -> Int -> Term 111 | lambdaAux f 0 = f [] 112 | lambdaAux f i = Lam (Scope ["_" ++ show i] $ \[x] -> lambdaAux (f . (x:)) (i-1)) 113 | 114 | 115 | 116 | forallHelper :: String -> Type -> Type 117 | forallHelper x b = Forall (scope [x] b) 118 | 119 | elabAlt :: String -> [String] -> String -> [Type] -> Elaborator () 120 | elabAlt tycon params n args 121 | = do when' (typeInSignature n) 122 | $ throwError ("Constructor already declared: " ++ n) 123 | let args' = mapM abstract args 124 | ret' = abstract (TyCon tycon (map (TyVar . TyName) params)) 125 | consig' = ConSig (length params) (Scope params $ \vs -> 126 | let e = zip params vs 127 | in (runReader args' e, runReader ret' e)) 128 | liftTC (mapM_ isType args) 129 | addConstructor n consig' 130 | 131 | elabAlts :: String -> [String] -> [(String, [Type])] -> Elaborator () 132 | elabAlts _ _ [] = return () 133 | elabAlts tycon params ((n,args):cs) = do elabAlt tycon params n args 134 | elabAlts tycon params cs 135 | 136 | elabTypeDecl :: TypeDeclaration -> Elaborator () 137 | elabTypeDecl (TypeDeclaration tycon params alts) 138 | = do when' (isType (TyCon tycon (map (TyVar . TyName) params))) 139 | $ throwError ("Type constructor already declared: " ++ tycon) 140 | addTypeConstructor tycon (length params) 141 | elabAlts tycon params alts 142 | 143 | elabProgram :: Program -> Elaborator () 144 | elabProgram (Program stmts0) = go stmts0 145 | where 146 | go :: [Statement] -> Elaborator () 147 | go [] = return () 148 | go (TyDecl td:stmts) = do elabTypeDecl td 149 | go stmts 150 | go (TmDecl td:stmts) = do elabTermDecl td 151 | go stmts -------------------------------------------------------------------------------- /src/Dependent/Unification/Elaboration.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Dependent.Unification.Elaboration where 4 | 5 | import Control.Applicative ((<$>)) 6 | import Control.Monad.Except 7 | import Control.Monad.State 8 | 9 | import Scope 10 | import TypeChecker (extendDefinitions) 11 | import Dependent.Core.Abstraction 12 | import Dependent.Core.ConSig 13 | import Dependent.Core.Program 14 | import Dependent.Core.Term 15 | 16 | import Dependent.Unification.TypeChecking 17 | 18 | 19 | 20 | data ElabState 21 | = ElabState 22 | { elabSig :: Signature Term 23 | , elabDefs :: Definitions 24 | , elabCtx :: Context 25 | , elabNextName :: Int 26 | } 27 | 28 | type Elaborator a = StateT ElabState (Either String) a 29 | 30 | runElaborator :: Elaborator () -> Either String ElabState 31 | runElaborator elab = do (_,p) <- runStateT elab (ElabState [] [] [] 0) 32 | return p 33 | 34 | signature :: Elaborator (Signature Term) 35 | signature = elabSig <$> get 36 | 37 | context :: Elaborator Context 38 | context = elabCtx <$> get 39 | 40 | definitions :: Elaborator Definitions 41 | definitions = elabDefs <$> get 42 | 43 | putSignature :: Signature Term -> Elaborator () 44 | putSignature sig = do s <- get 45 | put (s { elabSig = sig }) 46 | 47 | putContext :: Context -> Elaborator () 48 | putContext ctx = do s <- get 49 | put (s { elabCtx = ctx}) 50 | 51 | putDefinitions :: Definitions -> Elaborator () 52 | putDefinitions defs = do s <- get 53 | put (s {elabDefs = defs }) 54 | 55 | when' :: TypeChecker a -> Elaborator () -> Elaborator () 56 | when' tc e = do ElabState sig defs ctx i <- get 57 | case runTypeChecker tc sig defs ctx i of 58 | Left _ -> return () 59 | Right _ -> e 60 | 61 | liftTC :: TypeChecker a -> Elaborator a 62 | liftTC tc = do ElabState sig defs ctx i <- get 63 | case runTypeChecker tc sig defs ctx i of 64 | Left e -> throwError e 65 | Right (a,s) -> do s' <- get 66 | put s' { elabNextName = tcNextName s } 67 | return a 68 | 69 | 70 | addDeclaration :: String -> Term -> Term -> Elaborator () 71 | addDeclaration n def ty = do defs <- definitions 72 | putDefinitions ((n,def,ty) : defs) 73 | 74 | addConstructor :: String -> ConSig Term -> Elaborator () 75 | addConstructor c consig 76 | = do sig <- signature 77 | putSignature ((c,consig):sig) 78 | 79 | 80 | 81 | 82 | elabTermDecl :: TermDeclaration -> Elaborator () 83 | elabTermDecl (TermDeclaration n ty def) 84 | = do when' (typeInDefinitions n) 85 | $ throwError ("Term already defined: " ++ n) 86 | liftTC (check ty Type) 87 | liftTC (extendDefinitions [(n,def,ty)] (check def ty)) 88 | addDeclaration n def ty 89 | elabTermDecl (WhereDeclaration n ty preclauses) 90 | = case preclauses of 91 | [] -> throwError "Cannot create an empty let-where definition." 92 | [(ps,xs,b)] | all isVarPat ps 93 | -> elabTermDecl (TermDeclaration n ty (helperFold lamHelper xs b)) 94 | (ps0,_,_):_ 95 | -> do let clauses = [ clauseHelper ps xs b | (ps,xs,b) <- preclauses ] 96 | psLength = length ps0 97 | mot = motiveAux psLength ty 98 | unless (psLength <= functionArgsLength ty) 99 | $ throwError $ "Cannot build a case expression motive for fewer than " ++ show psLength 100 | ++ " args from the type " ++ show ty 101 | elabTermDecl (TermDeclaration n ty (lambdaAux (\as -> Case as mot clauses) psLength)) 102 | where 103 | isVarPat :: Pattern -> Bool 104 | isVarPat (VarPat _) = True 105 | isVarPat _ = False 106 | 107 | lambdaAux :: ([Term] -> Term) -> Int -> Term 108 | lambdaAux f 0 = f [] 109 | lambdaAux f i = Lam (Scope ["_" ++ show i] $ \[x] -> lambdaAux (f . (x:)) (i-1)) 110 | 111 | functionArgsLength :: Term -> Int 112 | functionArgsLength (Fun _ sc) = 1 + functionArgsLength (descope (Var . Name) sc) 113 | functionArgsLength _ = 0 114 | 115 | motiveAux :: Int -> Term -> CaseMotive 116 | motiveAux 0 t = CaseMotiveNil t 117 | motiveAux i (Fun a (Scope ns b)) = CaseMotiveCons a (Scope ns (motiveAux (i-1) . b)) 118 | 119 | 120 | 121 | elabAlt :: String -> String -> ConSig Term -> Elaborator () 122 | elabAlt tycon c consig 123 | = do validConSig consig 124 | when' (typeInSignature c) 125 | $ throwError ("Constructor already declared: " ++ c) 126 | liftTC (checkifyConSig consig) 127 | addConstructor c consig 128 | where 129 | validConSig :: ConSig Term -> Elaborator () 130 | validConSig (ConSigNil (Con tc _)) 131 | = unless (tc == tycon) 132 | $ throwError $ "The constructor " ++ c ++ " should constructor a value of the type " ++ tycon 133 | ++ " but instead produces a " ++ tc 134 | validConSig (ConSigNil a) 135 | = throwError $ "The constructor " ++ c ++ " should constructor a value of the type " ++ tycon 136 | ++ " but instead produces " ++ show a 137 | validConSig (ConSigCons _ sc) 138 | = validConSig (descope (Var . Name) sc) 139 | 140 | elabTypeDecl :: TypeDeclaration -> Elaborator () 141 | elabTypeDecl (TypeDeclaration tycon tyconargs alts) 142 | = do let tyconSig = conSigHelper tyconargs Type 143 | when' (typeInSignature tycon) 144 | $ throwError ("Type constructor already declared: " ++ tycon) 145 | liftTC (checkifyConSig tyconSig) 146 | addConstructor tycon tyconSig 147 | mapM_ (uncurry (elabAlt tycon)) alts 148 | 149 | 150 | 151 | elabProgram :: Program -> Elaborator () 152 | elabProgram (Program stmts0) = go stmts0 153 | where 154 | go :: [Statement] -> Elaborator () 155 | go [] = return () 156 | go (TyDecl td:stmts) = do elabTypeDecl td 157 | go stmts 158 | go (TmDecl td:stmts) = do elabTermDecl td 159 | go stmts -------------------------------------------------------------------------------- /src/Dependent/Monadic/Elaboration.hs: -------------------------------------------------------------------------------- 1 | module Dependent.Monadic.Elaboration where 2 | 3 | import Control.Applicative ((<$>)) 4 | import Control.Monad.Except 5 | import Control.Monad.Reader 6 | import Control.Monad.State 7 | import Data.List (intercalate) 8 | import Data.Maybe (isJust) 9 | 10 | import Abs 11 | import Scope 12 | import TypeChecker (extendDefinitions) 13 | import Dependent.Core.Abstraction 14 | import Dependent.Core.ConSig 15 | import Dependent.Core.Program 16 | import Dependent.Core.Term 17 | 18 | import Dependent.Monadic.TypeChecking 19 | 20 | 21 | 22 | data ElabState 23 | = ElabState 24 | { elabSig :: Signature Term 25 | , elabDefs :: Definitions 26 | , elabCtx :: Context 27 | , elabNextName :: Int 28 | } 29 | 30 | type Elaborator a = StateT ElabState (Either String) a 31 | 32 | runElaborator :: Elaborator () -> Either String ElabState 33 | runElaborator elab = do (_,p) <- runStateT elab (ElabState [] [] [] 0) 34 | return p 35 | 36 | signature :: Elaborator (Signature Term) 37 | signature = elabSig <$> get 38 | 39 | context :: Elaborator Context 40 | context = elabCtx <$> get 41 | 42 | definitions :: Elaborator Definitions 43 | definitions = elabDefs <$> get 44 | 45 | putSignature :: Signature Term -> Elaborator () 46 | putSignature sig = do s <- get 47 | put (s { elabSig = sig }) 48 | 49 | putContext :: Context -> Elaborator () 50 | putContext ctx = do s <- get 51 | put (s { elabCtx = ctx}) 52 | 53 | putDefinitions :: Definitions -> Elaborator () 54 | putDefinitions defs = do s <- get 55 | put (s {elabDefs = defs }) 56 | 57 | when' :: TypeChecker a -> Elaborator () -> Elaborator () 58 | when' tc e = do ElabState sig defs ctx i <- get 59 | case runTypeChecker tc sig defs ctx i of 60 | Left _ -> return () 61 | Right _ -> e 62 | 63 | liftTC :: TypeChecker a -> Elaborator a 64 | liftTC tc = do ElabState sig defs ctx i <- get 65 | case runTypeChecker tc sig defs ctx i of 66 | Left e -> throwError e 67 | Right (a,s) -> do s' <- get 68 | put s' { elabNextName = tcNextName s } 69 | return a 70 | 71 | 72 | addDeclaration :: String -> Term -> Term -> Elaborator () 73 | addDeclaration n def ty = do defs <- definitions 74 | putDefinitions ((n,def,ty) : defs) 75 | 76 | addConstructor :: String -> ConSig Term -> Elaborator () 77 | addConstructor c consig 78 | = do sig <- signature 79 | putSignature ((c,consig):sig) 80 | 81 | 82 | 83 | 84 | elabTermDecl :: TermDeclaration -> Elaborator () 85 | elabTermDecl (TermDeclaration n ty def) 86 | = do when' (typeInDefinitions n) 87 | $ throwError ("Term already defined: " ++ n) 88 | liftTC (check ty Type) 89 | liftTC (extendDefinitions [(n,def,ty)] (check def ty)) 90 | addDeclaration n def ty 91 | elabTermDecl (WhereDeclaration n ty preclauses) 92 | = case preclauses of 93 | [] -> throwError "Cannot create an empty let-where definition." 94 | [(ps,xs,b)] | all isVarPat ps 95 | -> elabTermDecl (TermDeclaration n ty (helperFold lamHelper xs b)) 96 | (ps0,_,_):_ 97 | -> do let clauses = [ clauseHelper ps xs b | (ps,xs,b) <- preclauses ] 98 | psLength = length ps0 99 | mot = motiveAux psLength ty 100 | unless (psLength <= functionArgsLength ty) 101 | $ throwError $ "Cannot build a case expression motive for fewer than " ++ show psLength 102 | ++ " args from the type " ++ show ty 103 | elabTermDecl (TermDeclaration n ty (lambdaAux (\as -> Case as mot clauses) psLength)) 104 | where 105 | isVarPat :: Pattern -> Bool 106 | isVarPat (VarPat _) = True 107 | isVarPat _ = False 108 | 109 | lambdaAux :: ([Term] -> Term) -> Int -> Term 110 | lambdaAux f 0 = f [] 111 | lambdaAux f n = Lam (Scope ["_" ++ show n] $ \[x] -> lambdaAux (f . (x:)) (n-1)) 112 | 113 | functionArgsLength :: Term -> Int 114 | functionArgsLength (Fun _ sc) = 1 + functionArgsLength (descope (Var . Name) sc) 115 | functionArgsLength _ = 0 116 | 117 | motiveAux :: Int -> Term -> CaseMotive 118 | motiveAux 0 t = CaseMotiveNil t 119 | motiveAux n (Fun a (Scope ns b)) = CaseMotiveCons a (Scope ns (motiveAux (n-1) . b)) 120 | 121 | 122 | 123 | elabAlt :: String -> String -> ConSig Term -> Elaborator () 124 | elabAlt tycon c consig 125 | = do validConSig consig 126 | when' (typeInSignature c) 127 | $ throwError ("Constructor already declared: " ++ c) 128 | liftTC (checkConSig consig) 129 | addConstructor c consig 130 | where 131 | validConSig :: ConSig Term -> Elaborator () 132 | validConSig (ConSigNil (Con tc _)) 133 | = unless (tc == tycon) 134 | $ throwError $ "The constructor " ++ c ++ " should constructor a value of the type " ++ tycon 135 | ++ " but instead produces a " ++ tc 136 | validConSig (ConSigNil a) 137 | = throwError $ "The constructor " ++ c ++ " should constructor a value of the type " ++ tycon 138 | ++ " but instead produces " ++ show a 139 | validConSig (ConSigCons _ sc) 140 | = validConSig (descope (Var . Name) sc) 141 | 142 | elabTypeDecl :: TypeDeclaration -> Elaborator () 143 | elabTypeDecl (TypeDeclaration tycon tyconargs alts) 144 | = do let tyconSig = conSigHelper tyconargs Type 145 | when' (typeInSignature tycon) 146 | $ throwError ("Type constructor already declared: " ++ tycon) 147 | liftTC (checkConSig tyconSig) 148 | addConstructor tycon tyconSig 149 | mapM_ (uncurry (elabAlt tycon)) alts 150 | 151 | 152 | 153 | elabProgram :: Program -> Elaborator () 154 | elabProgram (Program stmts) = go stmts 155 | where 156 | go :: [Statement] -> Elaborator () 157 | go [] = return () 158 | go (TyDecl td:stmts) = do elabTypeDecl td 159 | go stmts 160 | go (TmDecl td:stmts) = do elabTermDecl td 161 | go stmts -------------------------------------------------------------------------------- /src/Simple/Monadic/Elaboration.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Simple.Monadic.Elaboration where 4 | 5 | import Control.Applicative ((<$>)) 6 | import Control.Monad.Except 7 | import Control.Monad.State 8 | 9 | import Scope 10 | import TypeChecker (extendDefinitions) 11 | 12 | import Simple.Core.Abstraction 13 | import Simple.Core.Term 14 | import Simple.Core.Type 15 | import Simple.Core.Program 16 | 17 | import Simple.Monadic.TypeChecking 18 | 19 | 20 | data ElabState 21 | = ElabState 22 | { elabSig :: Signature 23 | , elabDefs :: Definitions 24 | , elabCtx :: Context 25 | , elabNextName :: Int 26 | } 27 | 28 | type Elaborator a = StateT ElabState (Either String) a 29 | 30 | runElaborator :: Elaborator () -> Either String ElabState 31 | runElaborator elab = do (_,p) <- runStateT elab (ElabState (Signature [] []) [] [] 0) 32 | return p 33 | 34 | signature :: Elaborator Signature 35 | signature = elabSig <$> get 36 | 37 | context :: Elaborator Context 38 | context = elabCtx <$> get 39 | 40 | definitions :: Elaborator Definitions 41 | definitions = elabDefs <$> get 42 | 43 | putSignature :: Signature -> Elaborator () 44 | putSignature sig = do s <- get 45 | put (s { elabSig = sig }) 46 | 47 | putContext :: Context -> Elaborator () 48 | putContext ctx = do s <- get 49 | put (s { elabCtx = ctx}) 50 | 51 | putDefinitions :: Definitions -> Elaborator () 52 | putDefinitions defs = do s <- get 53 | put (s {elabDefs = defs }) 54 | 55 | when' :: TypeChecker a -> Elaborator () -> Elaborator () 56 | when' tc e = do ElabState sig defs ctx i <- get 57 | case runTypeChecker tc sig defs ctx i of 58 | Left _ -> return () 59 | Right _ -> e 60 | 61 | liftTC :: TypeChecker a -> Elaborator a 62 | liftTC tc = do ElabState sig defs ctx i <- get 63 | case runTypeChecker tc sig defs ctx i of 64 | Left e -> throwError e 65 | Right (a,s) -> do s' <- get 66 | put s' { elabNextName = tcNextName s } 67 | return a 68 | 69 | 70 | addDeclaration :: String -> Term -> Type -> Elaborator () 71 | addDeclaration n def ty = do defs <- definitions 72 | putDefinitions ((n,def,ty) : defs) 73 | 74 | addTypeConstructor :: String -> Elaborator () 75 | addTypeConstructor n = do Signature tycons consigs <- signature 76 | putSignature (Signature (n:tycons) consigs) 77 | 78 | addConstructor :: String -> String -> [Type] -> Elaborator () 79 | addConstructor tycon n args 80 | = do Signature tycons consigs <- signature 81 | let consig = ConSig args (TyCon tycon) 82 | putSignature (Signature tycons ((n,consig):consigs)) 83 | 84 | 85 | 86 | 87 | elabTermDecl :: TermDeclaration -> Elaborator () 88 | elabTermDecl (TermDeclaration n ty def) 89 | = do when' (typeInDefinitions n) 90 | $ throwError ("Term already defined: " ++ n) 91 | liftTC (isType ty) 92 | liftTC (extendDefinitions [(n,def,ty)] (check def ty)) 93 | addDeclaration n def ty 94 | elabTermDecl (WhereDeclaration n ty preclauses) 95 | = case preclauses of 96 | [] -> throwError "Cannot create an empty let-where definition." 97 | [(ps,xs,b)] | all isVarPat ps 98 | -> elabTermDecl (TermDeclaration n ty (helperFold lamHelper xs b)) 99 | (ps0,_,_):_ 100 | -> let clauses = [ clauseHelper ps xs b | (ps,xs,b) <- preclauses ] 101 | in elabTermDecl (TermDeclaration n ty (lambdaAux (\as -> Case as clauses) (length ps0))) 102 | where 103 | isVarPat :: Pattern -> Bool 104 | isVarPat (VarPat _) = True 105 | isVarPat _ = False 106 | 107 | lambdaAux :: ([Term] -> Term) -> Int -> Term 108 | lambdaAux f 0 = f [] 109 | lambdaAux f i = Lam (Scope ["_" ++ show i] $ \[x] -> lambdaAux (f . (x:)) (i-1)) 110 | 111 | {- 112 | whereTermDecl = do (x,t) <- try $ do 113 | _ <- reserved "let" 114 | x <- varName 115 | _ <- reservedOp ":" 116 | t <- datatype 117 | _ <- reserved "where" 118 | return (x,t) 119 | _ <- optional (reservedOp "|") 120 | preclauses <- patternMatchClause x `sepBy1` reservedOp "|" 121 | _ <- reserved "end" 122 | case preclauses of 123 | [(ps,xs,b)] | all isVar ps 124 | -> return $ TermDeclaration x t (helperFold lamHelper xs b) 125 | (ps0,_,_):_ 126 | -> let clauses = [ clauseHelper ps xs b | (ps,xs,b) <- preclauses ] 127 | in return $ TermDeclaration x t (lambdaAux (\as -> Case as clauses) (length ps0)) 128 | where 129 | isVar :: Pattern -> Bool 130 | isVar (VarPat _) = True 131 | isVar _ = False 132 | 133 | lambdaAux :: ([Term] -> Term) -> Int -> Term 134 | lambdaAux f 0 = f [] 135 | lambdaAux f n = Lam (Scope ["_" ++ show n] $ \[x] -> lambdaAux (f . (x:)) (n-1)) 136 | -} 137 | 138 | 139 | 140 | elabAlt :: String -> String -> [Type] -> Elaborator () 141 | elabAlt tycon n args 142 | = do when' (typeInSignature n) 143 | $ throwError ("Constructor already declared: " ++ n) 144 | liftTC (mapM_ isType args) 145 | addConstructor tycon n args 146 | 147 | elabAlts :: String -> [(String, [Type])] -> Elaborator () 148 | elabAlts _ [] = return () 149 | elabAlts tycon ((n,args):cs) = do elabAlt tycon n args 150 | elabAlts tycon cs 151 | 152 | elabTypeDecl :: TypeDeclaration -> Elaborator () 153 | elabTypeDecl (TypeDeclaration tycon alts) 154 | = do when' (isType (TyCon tycon)) 155 | $ throwError ("Type constructor already declared: " ++ tycon) 156 | addTypeConstructor tycon 157 | elabAlts tycon alts 158 | 159 | elabProgram :: Program -> Elaborator () 160 | elabProgram (Program stmts0) = go stmts0 161 | where 162 | go :: [Statement] -> Elaborator () 163 | go [] = return () 164 | go (TyDecl td:stmts) = do elabTypeDecl td 165 | go stmts 166 | go (TmDecl td:stmts) = do elabTermDecl td 167 | go stmts -------------------------------------------------------------------------------- /src/Simple/Monadic/TypeChecking.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Simple.Monadic.TypeChecking where 5 | 6 | import Control.Monad.Except 7 | import Control.Monad.State 8 | import Data.List (intercalate,find) 9 | 10 | import Env 11 | import Scope 12 | import TypeChecker 13 | import Simple.Core.Term 14 | import Simple.Core.Type 15 | 16 | 17 | 18 | -- Signatures 19 | 20 | data ConSig = ConSig [Type] Type 21 | 22 | instance Show ConSig where 23 | show (ConSig as r) = "(" ++ intercalate "," (map show as) ++ ")" ++ show r 24 | 25 | data Signature = Signature [String] [(String,ConSig)] 26 | 27 | instance Show Signature where 28 | show (Signature tycons consigs) 29 | = "Types: " ++ unwords tycons ++ "\n" ++ 30 | "Constructors:\n" ++ 31 | unlines [ " " ++ c ++ "(" ++ 32 | intercalate "," (map show args) ++ 33 | ") : " ++ show ret 34 | | (c,ConSig args ret) <- consigs 35 | ] 36 | 37 | 38 | 39 | 40 | -- Definitions 41 | 42 | type Definitions = [(String,Term,Type)] 43 | 44 | definitionsToEnvironment :: Definitions -> Environment String Term 45 | definitionsToEnvironment defs 46 | = [ (x,m) | (x,m,_) <- defs ] 47 | 48 | 49 | 50 | 51 | -- Contexts 52 | 53 | type Context = [(Int,String,Type)] 54 | 55 | 56 | 57 | 58 | -- Type Checking Monad 59 | 60 | data TCState 61 | = TCState 62 | { tcSig :: Signature 63 | , tcDefs :: Definitions 64 | , tcCtx :: Context 65 | , tcNextName :: Int 66 | } 67 | 68 | instance TypeCheckerState TCState where 69 | type Sig TCState = Signature 70 | type Defs TCState = Definitions 71 | type Ctx TCState = Context 72 | typeCheckerSig = tcSig 73 | putTypeCheckerSig s sig = s { tcSig = sig } 74 | typeCheckerDefs = tcDefs 75 | putTypeCheckerDefs s defs = s { tcDefs = defs } 76 | addTypeCheckerDefs s edefs = s { tcDefs = edefs ++ tcDefs s } 77 | typeCheckerCtx = tcCtx 78 | putTypeCheckerCtx s ctx = s { tcCtx = ctx } 79 | addTypeCheckerCtx s ectx = s { tcCtx = ectx ++ tcCtx s } 80 | typeCheckerNextName = tcNextName 81 | putTypeCheckerNextName s n = s { tcNextName = n } 82 | 83 | type TypeChecker a = StateT TCState (Either String) a 84 | 85 | runTypeChecker :: TypeChecker a -> Signature -> Definitions -> Context -> Int -> Either String (a,TCState) 86 | runTypeChecker tc sig defs ctx i 87 | = runStateT tc (TCState sig defs ctx i) 88 | 89 | tyconExists :: String -> TypeChecker () 90 | tyconExists n 91 | = do Signature tycons _ <- signature 92 | unless (n `elem` tycons) 93 | $ throwError $ "Unknown type constructor: " ++ n 94 | 95 | typeInSignature :: String -> TypeChecker ConSig 96 | typeInSignature n 97 | = do Signature _ consigs <- signature 98 | case lookup n consigs of 99 | Nothing -> throwError $ "Unknown constructor: " ++ n 100 | Just t -> return t 101 | 102 | typeInDefinitions :: String -> TypeChecker Type 103 | typeInDefinitions x 104 | = do defs <- definitions 105 | case find (\(y,_,_) -> y == x) defs of 106 | Nothing -> throwError $ "Unknown constant/defined term: " ++ x 107 | Just (_,_,t) -> return t 108 | 109 | typeInContext :: Int -> TypeChecker Type 110 | typeInContext i 111 | = do ctx <- context 112 | case find (\(j,_,_) -> j == i) ctx of 113 | Nothing -> throwError "Unbound automatically generated variable." 114 | Just (_,_,t) -> return t 115 | 116 | 117 | 118 | -- Type well-formedness 119 | 120 | isType :: Type -> TypeChecker () 121 | isType (TyCon tc) = tyconExists tc 122 | isType (Fun a b) = isType a >> isType b 123 | isType (Meta _) = throwError "Meta variables should not be present in the this type checker." 124 | 125 | 126 | 127 | -- Type Inference 128 | 129 | infer :: Term -> TypeChecker Type 130 | infer (Var (Name x)) 131 | = typeInDefinitions x 132 | infer (Var (Generated _ i)) 133 | = typeInContext i 134 | infer (Ann m t) 135 | = check m t >> return t 136 | infer (Lam _) 137 | = throwError "Cannot infer the type of a lambda expression." 138 | infer (App f a) 139 | = do Fun arg ret <- infer f 140 | check a arg 141 | return ret 142 | infer (Con c as) 143 | = do ConSig args ret <- typeInSignature c 144 | let las = length as 145 | largs = length args 146 | unless (las == largs) 147 | $ throwError $ c ++ " expects " ++ show largs ++ " " 148 | ++ (if largs == 1 then "arg" else "args") 149 | ++ " but was given " ++ show las 150 | zipWithM_ check as args 151 | return ret 152 | infer (Case ms cs) 153 | = do ts <- mapM infer ms 154 | inferClauses ts cs 155 | 156 | 157 | inferClause :: [Type] -> Clause -> TypeChecker Type 158 | inferClause patTys (Clause psc sc) 159 | = do let lps = length (descope Name psc) 160 | unless (length patTys == lps) 161 | $ throwError $ "Mismatching number of patterns. Expected " ++ show (length patTys) 162 | ++ " but found " ++ show lps 163 | is <- replicateM (length (names psc)) newName 164 | let xs1 = zipWith Generated (names psc) is 165 | xs2 = map Var (removeByDummies (names psc) xs1) 166 | ctx' <- fmap concat $ zipWithM checkPattern (instantiate psc xs1) patTys 167 | extendContext ctx' 168 | $ infer (instantiate sc xs2) 169 | 170 | inferClauses :: [Type] -> [Clause] -> TypeChecker Type 171 | inferClauses patTys cs 172 | = do ts <- mapM (inferClause patTys) cs 173 | case ts of 174 | [] -> throwError "Empty clauses." 175 | t:ts' 176 | | all (== t) ts' -> return t 177 | | otherwise -> 178 | throwError $ "Clauses do not all return the same type:\n" 179 | ++ unlines (map show ts) 180 | 181 | 182 | 183 | -- Type Checking 184 | 185 | check :: Term -> Type -> TypeChecker () 186 | check (Lam sc) (Fun arg ret) 187 | = do i <- newName 188 | extendContext [(i, head (names sc), arg)] 189 | $ check (instantiate sc [Var (Generated (head (names sc)) i)]) ret 190 | check (Lam sc) t 191 | = throwError $ "Cannot check term: " ++ show (Lam sc) ++ "\n" 192 | ++ "Against non-function type: " ++ show t 193 | check m t 194 | = do t' <- infer m 195 | unless (t == t') 196 | $ throwError $ "Expected term: " ++ show m ++ "\n" 197 | ++ "To have type: " ++ show t ++ "\n" 198 | ++ "Instead found type: " ++ show t' 199 | 200 | 201 | 202 | checkPattern :: Pattern -> Type -> TypeChecker Context 203 | checkPattern (VarPat (Name _)) _ 204 | = return [] 205 | checkPattern (VarPat (Generated x i)) t 206 | = return [(i,x,t)] 207 | checkPattern (ConPat c ps) t 208 | = do ConSig args ret <- typeInSignature c 209 | let lps = length ps 210 | largs = length args 211 | unless (lps == largs && t == ret) 212 | $ throwError $ c ++ " expects " ++ show largs ++ " " 213 | ++ (if largs == 1 then "arg" else "args") 214 | ++ " but was given " ++ show lps 215 | rss <- zipWithM checkPattern ps args 216 | return $ concat rss -------------------------------------------------------------------------------- /src/Simple/Core/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | module Simple.Core.Parser where 6 | 7 | import Control.Applicative ((<$>),(<*>),(*>),(<*)) 8 | import Control.Monad (guard) 9 | import Data.List (foldl') 10 | import Text.Parsec 11 | import qualified Text.Parsec.Token as Token 12 | 13 | import Abs 14 | import Scope 15 | import Simple.Core.Abstraction 16 | import Simple.Core.Term 17 | import Simple.Core.Type 18 | import Simple.Core.Program 19 | 20 | 21 | 22 | 23 | 24 | -- Language Definition 25 | 26 | languageDef :: Token.LanguageDef st 27 | languageDef = Token.LanguageDef 28 | { Token.commentStart = "{-" 29 | , Token.commentEnd = "-}" 30 | , Token.commentLine = "--" 31 | , Token.nestedComments = True 32 | , Token.identStart = letter <|> char '_' 33 | , Token.identLetter = alphaNum <|> char '_' <|> char '\'' 34 | , Token.opStart = oneOf "" 35 | , Token.opLetter = oneOf "" 36 | , Token.reservedNames = ["data","case","of","end","where","let"] 37 | , Token.reservedOpNames = ["|","->","\\",":","=","||"] 38 | , Token.caseSensitive = True 39 | } 40 | 41 | tokenParser = Token.makeTokenParser languageDef 42 | 43 | identifier = Token.identifier tokenParser 44 | reserved = Token.reserved tokenParser 45 | reservedOp = Token.reservedOp tokenParser 46 | parens = Token.parens tokenParser 47 | symbol = Token.symbol tokenParser 48 | 49 | 50 | 51 | 52 | 53 | -- names 54 | 55 | varName = do lookAhead (lower <|> char '_') 56 | identifier 57 | 58 | decName = do lookAhead upper 59 | identifier 60 | 61 | 62 | -- type parsers 63 | 64 | typeCon = TyCon <$> decName 65 | 66 | funType = do arg <- try $ do 67 | arg <- funLeft 68 | _ <- reservedOp "->" 69 | return arg 70 | ret <- funRight 71 | return $ Fun arg ret 72 | 73 | parenType = parens datatype 74 | 75 | funLeft = typeCon <|> parenType 76 | 77 | funRight = funType <|> typeCon <|> parenType 78 | 79 | datatype = funType <|> typeCon <|> parenType 80 | 81 | 82 | -- term parsers 83 | 84 | variable = do x <- varName 85 | guard (x /= "_") 86 | return $ Var (Name x) 87 | 88 | annotation = do m <- try $ do 89 | m <- annLeft 90 | _ <- reservedOp ":" 91 | return m 92 | t <- datatype 93 | return $ Ann m t 94 | 95 | lambda = do _ <- reservedOp "\\" 96 | xs <- many1 varName 97 | _ <- reservedOp "->" 98 | b <- lamBody 99 | return $ helperFold lamHelper xs b 100 | 101 | application = do (f,a) <- try $ do 102 | f <- appFun 103 | a <- appArg 104 | return (f,a) 105 | as <- many appArg 106 | return $ foldl' App f (a:as) 107 | 108 | noArgConData = do c <- decName 109 | return $ Con c [] 110 | 111 | conData = do c <- decName 112 | as <- many conArg 113 | return $ Con c as 114 | 115 | varPattern = do x <- varName 116 | return (VarPat (Name x),[x]) 117 | 118 | noArgConPattern = do c <- decName 119 | return $ (ConPat c [], []) 120 | 121 | conPattern = do c <- decName 122 | psxs <- many conPatternArg 123 | let (ps,xs) = unzip psxs 124 | return $ (ConPat c ps, concat xs) 125 | 126 | parenPattern = parens pattern 127 | 128 | conPatternArg = parenPattern <|> noArgConPattern <|> varPattern 129 | 130 | pattern = parenPattern <|> conPattern <|> varPattern 131 | 132 | clause = do psxs <- try $ do 133 | psxs <- pattern `sepBy` reservedOp "||" 134 | _ <- reservedOp "->" 135 | return psxs 136 | b <- term 137 | let ps = map fst psxs 138 | xs = concat (map snd psxs) 139 | return $ clauseHelper ps xs b 140 | 141 | caseExp = do _ <- reserved "case" 142 | m <- caseArg `sepBy` reservedOp "||" 143 | _ <- reserved "of" 144 | _ <- optional (reservedOp "|") 145 | cs <- clause `sepBy` reservedOp "|" 146 | _ <- reserved "end" 147 | return $ Case m cs 148 | 149 | parenTerm = parens term 150 | 151 | annLeft = application <|> parenTerm <|> conData <|> variable 152 | 153 | lamBody = annotation <|> application <|> parenTerm <|> lambda <|> conData <|> caseExp <|> variable 154 | 155 | appFun = parenTerm <|> variable 156 | 157 | appArg = parenTerm <|> noArgConData <|> variable 158 | 159 | conArg = parenTerm <|> noArgConData <|> variable 160 | 161 | caseArg = annotation <|> application <|> parenTerm <|> lambda <|> conData <|> variable 162 | 163 | term = annotation <|> application <|> parenTerm <|> lambda <|> conData <|> caseExp <|> variable 164 | 165 | parseTerm str = case parse (spaces *> term <* eof) "(unknown)" str of 166 | Left e -> Left (show e) 167 | Right p -> Right p 168 | 169 | 170 | 171 | -- program parsers 172 | 173 | eqTermDecl = do (x,t) <- try $ do 174 | _ <- reserved "let" 175 | x <- varName 176 | _ <- reservedOp ":" 177 | t <- datatype 178 | _ <- reservedOp "=" 179 | return (x,t) 180 | m <- term 181 | _ <- reserved "end" 182 | return $ TermDeclaration x t m 183 | 184 | whereTermDecl = do (x,t) <- try $ do 185 | _ <- reserved "let" 186 | x <- varName 187 | _ <- reservedOp ":" 188 | t <- datatype 189 | _ <- reserved "where" 190 | return (x,t) 191 | _ <- optional (reservedOp "|") 192 | preclauses <- patternMatchClause x `sepBy1` reservedOp "|" 193 | _ <- reserved "end" 194 | return $ WhereDeclaration x t preclauses 195 | 196 | patternMatchClause x = do _ <- symbol x 197 | psxs <- many patternMatchPattern 198 | _ <- reservedOp "=" 199 | b <- term 200 | let ps = map fst psxs 201 | xs = concat (map snd psxs) 202 | return (ps,xs,b) 203 | 204 | patternMatchPattern = parenPattern <|> noArgConPattern <|> varPattern 205 | 206 | termDecl = eqTermDecl <|> whereTermDecl 207 | 208 | alternative = do c <- decName 209 | as <- many alternativeArg 210 | return (c,as) 211 | 212 | alternativeArg = parenType <|> typeCon 213 | 214 | typeDecl = do _ <- reserved "data" 215 | tycon <- decName 216 | alts <- option [] $ do 217 | _ <- reservedOp "=" 218 | alternative `sepBy` reservedOp "|" 219 | _ <- reserved "end" 220 | return $ TypeDeclaration tycon alts 221 | 222 | statement = TmDecl <$> termDecl 223 | <|> TyDecl <$> typeDecl 224 | 225 | program = Program <$> many statement 226 | 227 | 228 | 229 | parseProgram :: String -> Either String Program 230 | parseProgram str 231 | = case parse (spaces *> program <* eof) "(unknown)" str of 232 | Left e -> Left (show e) 233 | Right p -> Right p -------------------------------------------------------------------------------- /src/DependentImplicit/Unification/Elaboration.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module DependentImplicit.Unification.Elaboration where 4 | 5 | import Control.Applicative ((<$>)) 6 | import Control.Monad.Except 7 | import Control.Monad.State 8 | 9 | import Plicity 10 | import Scope 11 | import TypeChecker (extendDefinitions) 12 | import DependentImplicit.Core.Abstraction 13 | import DependentImplicit.Core.ConSig 14 | import DependentImplicit.Core.Program 15 | import DependentImplicit.Core.Term 16 | import DependentImplicit.Unification.TypeChecking 17 | 18 | 19 | 20 | data ElabState 21 | = ElabState 22 | { elabSig :: Signature Term 23 | , elabDefs :: Definitions 24 | , elabCtx :: Context 25 | , elabNextName :: Int 26 | } 27 | 28 | type Elaborator a = StateT ElabState (Either String) a 29 | 30 | runElaborator :: Elaborator () -> Either String ElabState 31 | runElaborator elab = do (_,p) <- runStateT elab (ElabState [] [] [] 0) 32 | return p 33 | 34 | signature :: Elaborator (Signature Term) 35 | signature = elabSig <$> get 36 | 37 | context :: Elaborator Context 38 | context = elabCtx <$> get 39 | 40 | definitions :: Elaborator Definitions 41 | definitions = elabDefs <$> get 42 | 43 | putSignature :: Signature Term -> Elaborator () 44 | putSignature sig = do s <- get 45 | put (s { elabSig = sig }) 46 | 47 | putContext :: Context -> Elaborator () 48 | putContext ctx = do s <- get 49 | put (s { elabCtx = ctx}) 50 | 51 | putDefinitions :: Definitions -> Elaborator () 52 | putDefinitions defs = do s <- get 53 | put (s {elabDefs = defs }) 54 | 55 | when' :: TypeChecker a -> Elaborator () -> Elaborator () 56 | when' tc e = do ElabState sig defs ctx i <- get 57 | case runTypeChecker tc sig defs ctx i of 58 | Left _ -> return () 59 | Right _ -> e 60 | 61 | liftTC :: TypeChecker a -> Elaborator a 62 | liftTC tc = do ElabState sig defs ctx i <- get 63 | case runTypeChecker tc sig defs ctx i of 64 | Left e -> throwError e 65 | Right (a,s) -> do s' <- get 66 | put s' { elabNextName = tcNextName s } 67 | return a 68 | 69 | 70 | addDeclaration :: String -> Term -> Term -> Elaborator () 71 | addDeclaration n def ty = do defs <- definitions 72 | putDefinitions ((n,def,ty) : defs) 73 | 74 | addConstructor :: String -> ConSig Term -> Elaborator () 75 | addConstructor c consig 76 | = do sig <- signature 77 | putSignature ((c,consig):sig) 78 | 79 | 80 | 81 | 82 | elabTermDecl :: TermDeclaration -> Elaborator () 83 | elabTermDecl (TermDeclaration n ty def) 84 | = do when' (typeInDefinitions n) 85 | $ throwError ("Term already defined: " ++ n) 86 | ty' <- liftTC (check ty Type) 87 | def' <- liftTC (extendDefinitions [(n,def,ty')] (check def ty')) 88 | addDeclaration n def' ty' 89 | elabTermDecl (WhereDeclaration n ty preclauses) 90 | = case preclauses of 91 | [] -> throwError "Cannot create an empty let-where definition." 92 | [(plics,(ps,xs,b))] | all isVarPat ps 93 | -> elabTermDecl (TermDeclaration n ty (helperFold (uncurry lamHelper) (zip plics xs) b)) 94 | (_,(ps0,_,_)):_ 95 | -> do let lps0 = length ps0 96 | unless (all (\(_,(ps,_,_)) -> length ps == lps0) preclauses) 97 | $ throwError "Mismatching number of patterns in different clauses of a pattern matching function." 98 | let (plics:plicss) = map fst preclauses 99 | unless (all (plics==) plicss) 100 | $ throwError "Mismatching plicities in different clauses of a pattern matching function" 101 | case truePlicities plics ty of 102 | Nothing 103 | -> throwError $ "Cannot build a case expression motive from the type " ++ show ty 104 | Just truePlics 105 | -> do let mot = motiveAux (length truePlics) ty 106 | clauses = [ clauseHelper (truePatterns truePlics ps) xs b | (_,(ps,xs,b)) <- preclauses ] 107 | plicsForLambdaAux = map (either id id) truePlics 108 | elabTermDecl (TermDeclaration n ty (lambdaAux (\as -> Case as mot clauses) plicsForLambdaAux)) 109 | where 110 | isVarPat :: Pattern -> Bool 111 | isVarPat (VarPat _) = True 112 | isVarPat _ = False 113 | 114 | lambdaAux :: ([Term] -> Term) -> [Plicity] -> Term 115 | lambdaAux f [] = f [] 116 | lambdaAux f (plic:plics) = Lam plic (Scope ["_" ++ show (length plics)] $ \[x] -> lambdaAux (f . (x:)) plics) 117 | 118 | truePlicities :: [Plicity] -> Term -> Maybe [Either Plicity Plicity] 119 | truePlicities [] _ = Just [] 120 | truePlicities (Expl:plics) (Fun Expl _ sc) 121 | = do rest <- truePlicities plics (descope (Var . Name) sc) 122 | return $ Right Expl : rest 123 | truePlicities (Expl:plics) (Fun Impl _ sc) 124 | = do rest <- truePlicities (Expl : plics) (descope (Var . Name) sc) 125 | return $ Left Impl : rest 126 | truePlicities (Impl:_) (Fun Expl _ _) 127 | = Nothing 128 | truePlicities (Impl:plics) (Fun Impl _ sc) 129 | = do rest <- truePlicities plics (descope (Var . Name) sc) 130 | return $ Right Impl : rest 131 | 132 | motiveAux :: Int -> Term -> CaseMotive 133 | motiveAux 0 t = CaseMotiveNil t 134 | motiveAux i (Fun _ a (Scope ns b)) = CaseMotiveCons a (Scope ns (motiveAux (i-1) . b)) 135 | 136 | truePatterns :: [Either Plicity Plicity] -> [Pattern] -> [Pattern] 137 | truePatterns [] [] = [] 138 | truePatterns (Right _:plics) (p:ps) 139 | = p : truePatterns plics ps 140 | truePatterns (Left _:plics) ps 141 | = MakeMeta : truePatterns plics ps 142 | 143 | 144 | 145 | elabAlt :: String -> String -> ConSig Term -> Elaborator () 146 | elabAlt tycon c consig 147 | = do validConSig consig 148 | when' (typeInSignature c) 149 | $ throwError ("Constructor already declared: " ++ c) 150 | consig' <- liftTC (checkifyConSig consig) 151 | addConstructor c consig' 152 | where 153 | validConSig :: ConSig Term -> Elaborator () 154 | validConSig (ConSigNil (Con tc _)) 155 | = unless (tc == tycon) 156 | $ throwError $ "The constructor " ++ c ++ " should constructor a value of the type " ++ tycon 157 | ++ " but instead produces a " ++ tc 158 | validConSig (ConSigNil a) 159 | = throwError $ "The constructor " ++ c ++ " should constructor a value of the type " ++ tycon 160 | ++ " but instead produces " ++ show a 161 | validConSig (ConSigCons _ _ sc) 162 | = validConSig (descope (Var . Name) sc) 163 | 164 | elabTypeDecl :: TypeDeclaration -> Elaborator () 165 | elabTypeDecl (TypeDeclaration tycon tyconargs alts) 166 | = do let tyconSig = conSigHelper tyconargs Type 167 | when' (typeInSignature tycon) 168 | $ throwError ("Type constructor already declared: " ++ tycon) 169 | tyconSig' <- liftTC (checkifyConSig tyconSig) 170 | addConstructor tycon tyconSig' 171 | mapM_ (uncurry (elabAlt tycon)) alts 172 | 173 | 174 | 175 | elabProgram :: Program -> Elaborator () 176 | elabProgram (Program stmts0) = go stmts0 177 | where 178 | go :: [Statement] -> Elaborator () 179 | go [] = return () 180 | go (TyDecl td:stmts) = do elabTypeDecl td 181 | go stmts 182 | go (TmDecl td:stmts) = do elabTermDecl td 183 | go stmts -------------------------------------------------------------------------------- /src/DependentImplicit/Core/Term.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | 7 | module DependentImplicit.Core.Term where 8 | 9 | import Data.List (intercalate,nub) 10 | 11 | import Parens 12 | import Plicity 13 | import Scope 14 | 15 | 16 | 17 | 18 | 19 | -- Used in multiple places 20 | 21 | data DeclArg 22 | = DeclArg Plicity String Term 23 | 24 | instance Show DeclArg where 25 | show (DeclArg Expl x t) = "(" ++ x ++ " : " ++ show t ++ ")" 26 | show (DeclArg Impl x t) = "{" ++ x ++ " : " ++ show t ++ "}" 27 | 28 | 29 | 30 | -- Terms 31 | 32 | data Variable 33 | = Name String 34 | | Generated String Int 35 | 36 | instance Eq Variable where 37 | Name x == Name y = x == y 38 | Generated _ i == Generated _ j = i == j 39 | _ == _ = False 40 | 41 | data Term 42 | = Meta Int 43 | | Var Variable 44 | | Ann Term Term 45 | | Type 46 | | Fun Plicity Term (Scope Term Term) 47 | | Lam Plicity (Scope Term Term) 48 | | App Plicity Term Term 49 | | Con String [(Plicity, Term)] 50 | | Case [Term] CaseMotive [Clause] 51 | 52 | data CaseMotive 53 | = CaseMotiveNil Term 54 | | CaseMotiveCons Term (Scope Term CaseMotive) 55 | 56 | data Clause 57 | = Clause (Scope Variable [Pattern]) (Scope Term Term) 58 | 59 | data Pattern 60 | = VarPat Variable 61 | | ConPat String [(Plicity,Pattern)] 62 | | AssertionPat Term 63 | | MakeMeta 64 | 65 | 66 | 67 | 68 | -- Case Motive Length 69 | 70 | caseMotiveLength :: CaseMotive -> Int 71 | caseMotiveLength (CaseMotiveNil _) = 0 72 | caseMotiveLength (CaseMotiveCons _ sc) 73 | = 1 + caseMotiveLength (descope (Var . Name) sc) 74 | 75 | 76 | 77 | 78 | -- Show Instances 79 | 80 | instance Show Variable where 81 | show (Name x) = x 82 | show (Generated x _) = x 83 | 84 | data PatternParenLoc = ExplConPatArg | ImplConPatArg 85 | deriving (Eq) 86 | 87 | instance ParenLoc Pattern where 88 | type Loc Pattern = PatternParenLoc 89 | parenLoc (VarPat _) = [ExplConPatArg,ImplConPatArg] 90 | parenLoc (ConPat _ _) = [ImplConPatArg] 91 | parenLoc (AssertionPat _) = [ExplConPatArg,ImplConPatArg] 92 | parenLoc MakeMeta = [ExplConPatArg,ImplConPatArg] 93 | 94 | instance ParenRec Pattern where 95 | parenRec (VarPat x) 96 | = show x 97 | parenRec (ConPat c []) 98 | = c 99 | parenRec (ConPat c ps) 100 | = c ++ " " ++ unwords (map auxConPatArg ps) 101 | where 102 | auxConPatArg :: (Plicity,Pattern) -> String 103 | auxConPatArg (Expl,p) = parenthesize (Just ExplConPatArg) p 104 | auxConPatArg (Impl,p) = "{" ++ parenthesize (Just ImplConPatArg) p ++ "}" 105 | parenRec (AssertionPat m) 106 | = "." ++ parenthesize (Just AssertionPatArg) m 107 | parenRec MakeMeta 108 | = "?makemeta" 109 | 110 | instance Show Pattern where 111 | show p = parenthesize Nothing p 112 | 113 | 114 | 115 | data TermParenLoc 116 | = RootTerm 117 | | AnnLeft | AnnRight 118 | | FunArg | FunRet 119 | | LamBody | AppLeft | ExplAppRight | ImplAppRight 120 | | ExplConArg | ImplConArg | AssertionPatArg 121 | deriving (Eq) 122 | 123 | instance ParenLoc Term where 124 | type Loc Term = TermParenLoc 125 | parenLoc (Meta _) 126 | = [AnnLeft,FunArg,FunRet,LamBody,AppLeft,ExplAppRight,ImplAppRight,ExplConArg,ImplConArg,AssertionPatArg] 127 | parenLoc (Var _) 128 | = [AnnLeft,FunArg,FunRet,LamBody,AppLeft,ExplAppRight,ImplAppRight,ExplConArg,ImplConArg,AssertionPatArg] 129 | parenLoc (Ann _ _) 130 | = [FunArg,FunRet,LamBody,ImplAppRight,ImplConArg] 131 | parenLoc Type 132 | = [AnnLeft,FunArg,FunRet,LamBody,AppLeft,ExplAppRight,ImplAppRight,ExplConArg,ImplConArg,AssertionPatArg] 133 | parenLoc (Fun _ _ _) 134 | = [FunArg,FunRet,LamBody,ImplAppRight,ImplConArg] 135 | parenLoc (Lam _ _) 136 | = [FunArg,FunRet,LamBody,ImplAppRight,ImplConArg] 137 | parenLoc (App _ _ _) 138 | = [FunArg,FunRet,AnnLeft,LamBody,AppLeft,ImplAppRight,ImplConArg] 139 | parenLoc (Con _ []) 140 | = [FunArg,FunRet,AnnLeft,LamBody,AppLeft,ExplAppRight,ImplAppRight,ExplConArg,ImplConArg,AssertionPatArg] 141 | parenLoc (Con _ _) 142 | = [FunArg,FunRet,AnnLeft,LamBody,ImplAppRight,ImplConArg] 143 | parenLoc (Case _ _ _) 144 | = [FunArg,FunRet,LamBody,ImplAppRight,ImplConArg] 145 | 146 | instance ParenRec Term where 147 | parenRec (Meta i) 148 | = "?" ++ show i 149 | parenRec (Var x) 150 | = show x 151 | parenRec (Ann m ty) 152 | = parenthesize (Just AnnLeft) m ++ " : " ++ parenthesize (Just AnnRight) ty 153 | parenRec Type 154 | = "Type" 155 | parenRec (Fun plic a sc) 156 | = let a0' = unwords (names sc) ++ " : " ++ parenthesize (Just FunArg) a 157 | a' = case plic of 158 | Expl -> "(" ++ a0' ++ ")" 159 | Impl -> "{" ++ a0' ++ "}" 160 | in a' ++ " -> " 161 | ++ parenthesize (Just FunRet) 162 | (descope (Var . Name) sc) 163 | parenRec (Lam plic sc) 164 | = let n0' = unwords (names sc) 165 | n' = case plic of 166 | Expl -> n0' 167 | Impl -> "{" ++ n0' ++ "}" 168 | in "\\" ++ n' 169 | ++ " -> " ++ parenthesize (Just LamBody) 170 | (descope (Var . Name) sc) 171 | parenRec (App plic f a) 172 | = let a' = case plic of 173 | Expl -> parenthesize (Just ExplAppRight) a 174 | Impl -> "{" ++ parenthesize (Just ImplAppRight) a ++ "}" 175 | in parenthesize (Just AppLeft) f ++ " " ++ a' 176 | parenRec (Con c []) 177 | = c 178 | parenRec (Con c as) 179 | = let as' = [ case plic of 180 | Expl -> parenthesize (Just ExplConArg) a 181 | Impl -> "{" ++ parenthesize (Just ImplConArg) a ++ "}" 182 | | (plic,a) <- as 183 | ] 184 | in c ++ " " ++ intercalate " " as' --(map (parenthesize (Just ConArg)) as) 185 | parenRec (Case ms mot cs) 186 | = "case " ++ intercalate " || " (map (parenthesize Nothing) ms) 187 | ++ " motive " ++ show mot 188 | ++ " of " ++ intercalate " | " (map auxClause cs) ++ " end" 189 | where 190 | auxClause (Clause psc sc) 191 | = intercalate " || " (map show (descope Name psc)) 192 | ++ " -> " ++ parenthesize Nothing 193 | (descope (Var . Name) sc) 194 | 195 | 196 | 197 | 198 | instance Show Term where 199 | show t = parenthesize Nothing t 200 | 201 | 202 | 203 | instance Show CaseMotive where 204 | show (CaseMotiveNil ret) = show ret 205 | show (CaseMotiveCons arg sc) 206 | = "(" ++ unwords (names sc) ++ " : " ++ show arg ++ ") || " 207 | ++ show (descope (Var . Name) sc) 208 | 209 | 210 | 211 | patternVars :: Pattern -> [Variable] 212 | patternVars (VarPat v) = [v] 213 | patternVars (ConPat _ ps) = ps >>= (patternVars . snd) 214 | patternVars (AssertionPat _) = [] 215 | patternVars MakeMeta = [] 216 | 217 | metas :: Term -> [Int] 218 | metas x = nub (go x) 219 | where 220 | go (Meta i) = [i] 221 | go (Var _) = [] 222 | go (Ann m t) = go m ++ go t 223 | go Type = [] 224 | go (Fun _ a sc) = go a ++ go (descope (Var . Name) sc) 225 | go (Lam _ sc) = go (descope (Var . Name) sc) 226 | go (App _ f x) = go f ++ metas x 227 | go (Con _ xs) = concat (map (go . snd) xs) 228 | go (Case as mot cs) = concat (map go as) ++ goCaseMotive mot ++ concat (map goClause cs) 229 | 230 | goPat (VarPat _) = [] 231 | goPat (ConPat _ ps) = concat (map (goPat . snd) ps) 232 | goPat (AssertionPat m) = go m 233 | goPat MakeMeta = [] 234 | 235 | goCaseMotive (CaseMotiveNil t) = go t 236 | goCaseMotive (CaseMotiveCons a sc) = go a ++ goCaseMotive (descope (Var . Name) sc) 237 | 238 | goClause (Clause psc sc) = concat (map goPat (descope Name psc)) ++ go (descope (Var . Name) sc) 239 | 240 | termToPattern :: Term -> Pattern 241 | termToPattern (Var x) = VarPat x 242 | termToPattern (Con c xs) = ConPat c [ (plic, termToPattern x) | (plic,x) <- xs ] 243 | termToPattern m = AssertionPat m -------------------------------------------------------------------------------- /src/DependentImplicit/Core/Abstraction.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module DependentImplicit.Core.Abstraction where 9 | 10 | import Control.Applicative 11 | import Control.Monad.Reader 12 | import qualified Control.Monad.State as S 13 | 14 | import Abs 15 | import Plicity 16 | import Scope 17 | import DependentImplicit.Core.ConSig 18 | import DependentImplicit.Core.Term 19 | 20 | instance Abstract a b c => Abstract a b (Plicity,c) where 21 | abstract (plic,x) = (,) plic <$> abstract x 22 | 23 | instance (Abstract a b Pattern, Abstract a b Term) => Abstract a b Clause where 24 | abstract (Clause psc sc) 25 | = Clause <$> abstractScope psc <*> abstractScope sc 26 | 27 | instance Abstract a b Term => Abstract a b CaseMotive where 28 | abstract (CaseMotiveNil a) 29 | = CaseMotiveNil <$> abstract a 30 | abstract (CaseMotiveCons a sc) 31 | = CaseMotiveCons <$> abstract a <*> abstractScope sc 32 | 33 | instance Abstract String Term Term where 34 | abstract (Meta i) 35 | = return $ Meta i 36 | abstract (Var (Name x)) 37 | = reader $ \e -> 38 | case lookup x e of 39 | Nothing -> Var (Name x) 40 | Just m -> m 41 | abstract (Var (Generated x i)) 42 | = return $ Var (Generated x i) 43 | abstract (Ann m ty) 44 | = Ann <$> abstract m <*> return ty 45 | abstract Type 46 | = return Type 47 | abstract (Fun plic a sc) 48 | = Fun plic <$> abstract a <*> abstractScope sc 49 | abstract (Lam plic sc) 50 | = Lam plic <$> abstractScope sc 51 | abstract (App plic f a) 52 | = App plic <$> abstract f <*> abstract a 53 | abstract (Con c as) 54 | = Con c <$> forM as (\(plic,a) -> do a' <- abstract a ; return (plic,a')) 55 | abstract (Case as t cs) 56 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 57 | 58 | instance Abstract Int Term Term where 59 | abstract (Meta i) 60 | = return $ Meta i 61 | abstract (Var (Name x)) 62 | = return $ Var (Name x) 63 | abstract (Var (Generated x i)) 64 | = reader $ \e -> 65 | case lookup i e of 66 | Nothing -> Var (Generated x i) 67 | Just m -> m 68 | abstract (Ann m ty) 69 | = Ann <$> abstract m <*> return ty 70 | abstract Type 71 | = return Type 72 | abstract (Fun plic a sc) 73 | = Fun plic <$> abstract a <*> abstractScope sc 74 | abstract (Lam plic sc) 75 | = Lam plic <$> abstractScope sc 76 | abstract (App plic f a) 77 | = App plic <$> abstract f <*> abstract a 78 | abstract (Con c as) 79 | = Con c <$> forM as (\(plic,a) -> do a' <- abstract a ; return (plic,a')) 80 | abstract (Case as t cs) 81 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 82 | 83 | instance Abstract String Variable Term where 84 | abstract (Meta i) 85 | = return $ Meta i 86 | abstract (Var (Name x)) 87 | = reader $ \e -> 88 | case lookup x e of 89 | Nothing -> Var (Name x) 90 | Just y -> Var y 91 | abstract (Var (Generated x i)) 92 | = return $ Var (Generated x i) 93 | abstract (Ann m ty) 94 | = Ann <$> abstract m <*> return ty 95 | abstract Type 96 | = return Type 97 | abstract (Fun plic a sc) 98 | = Fun plic <$> abstract a <*> abstractScope sc 99 | abstract (Lam plic sc) 100 | = Lam plic <$> abstractScope sc 101 | abstract (App plic f a) 102 | = App plic <$> abstract f <*> abstract a 103 | abstract (Con c as) 104 | = Con c <$> forM as (\(plic,a) -> do a' <- abstract a ; return (plic,a')) 105 | abstract (Case as t cs) 106 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 107 | 108 | instance Abstract Int Variable Term where 109 | abstract (Meta i) 110 | = return $ Meta i 111 | abstract (Var (Name x)) 112 | = return $ Var (Name x) 113 | abstract (Var (Generated x i)) 114 | = reader $ \e -> 115 | case lookup i e of 116 | Nothing -> Var (Generated x i) 117 | Just y -> Var y 118 | abstract (Ann m ty) 119 | = Ann <$> abstract m <*> return ty 120 | abstract Type 121 | = return Type 122 | abstract (Fun plic a sc) 123 | = Fun plic <$> abstract a <*> abstractScope sc 124 | abstract (Lam plic sc) 125 | = Lam plic <$> abstractScope sc 126 | abstract (App plic f a) 127 | = App plic <$> abstract f <*> abstract a 128 | abstract (Con c as) 129 | = Con c <$> forM as (\(plic,a) -> do a' <- abstract a ; return (plic,a')) 130 | abstract (Case as t cs) 131 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 132 | 133 | instance Abstract String Term Pattern where 134 | abstract (VarPat x) 135 | = return $ VarPat x 136 | abstract (ConPat c ps) 137 | = ConPat c <$> mapM abstract ps 138 | abstract (AssertionPat m) 139 | = AssertionPat <$> abstract m 140 | abstract MakeMeta 141 | = return MakeMeta 142 | 143 | instance Abstract Int Term Pattern where 144 | abstract (VarPat x) 145 | = return $ VarPat x 146 | abstract (ConPat c ps) 147 | = ConPat c <$> mapM abstract ps 148 | abstract (AssertionPat m) 149 | = AssertionPat <$> abstract m 150 | abstract MakeMeta 151 | = return MakeMeta 152 | 153 | instance Abstract String Variable Pattern where 154 | abstract (VarPat (Name x)) 155 | = reader $ \e -> 156 | case lookup x e of 157 | Nothing -> VarPat (Name x) 158 | Just y -> VarPat y 159 | abstract (VarPat (Generated x i)) 160 | = return $ VarPat (Generated x i) 161 | abstract (ConPat c ps) 162 | = ConPat c <$> mapM abstract ps 163 | abstract (AssertionPat m) 164 | = AssertionPat <$> abstract m 165 | abstract MakeMeta 166 | = return MakeMeta 167 | 168 | instance Abstract Int Variable Pattern where 169 | abstract (VarPat (Name x)) 170 | = return $ VarPat (Name x) 171 | abstract (VarPat (Generated x i)) 172 | = reader $ \e -> 173 | case lookup i e of 174 | Nothing -> VarPat (Generated x i) 175 | Just y -> VarPat y 176 | abstract (ConPat c ps) 177 | = ConPat c <$> mapM abstract ps 178 | abstract (AssertionPat m) 179 | = AssertionPat <$> abstract m 180 | abstract MakeMeta 181 | = return MakeMeta 182 | 183 | funHelper :: Plicity -> String -> Term -> Term -> Term 184 | funHelper plic x a b = Fun plic a (scope [x] b) 185 | 186 | lamHelper :: Plicity -> String -> Term -> Term 187 | lamHelper plic x b = Lam plic (scope [x] b) 188 | 189 | clauseHelper :: [Pattern] -> [String] -> Term -> Clause 190 | clauseHelper ps xs b = Clause (scope2 xs cleanedXs cleanedPs) (scope (filter isVar xs) b) 191 | where 192 | cleanedXs = fst (S.runState (mapM cleanXs xs) 0) 193 | 194 | cleanXs :: String -> S.State Int String 195 | cleanXs "_" = do i <- S.get 196 | S.put (i+1) 197 | return $ "$" ++ show i 198 | cleanXs x = return x 199 | 200 | cleanedPs = fst (S.runState (mapM cleanPs ps) 0) 201 | 202 | cleanPs :: Pattern -> S.State Int Pattern 203 | cleanPs (VarPat (Name "_")) 204 | = do i <- S.get 205 | S.put (i+1) 206 | return $ VarPat (Name ("$" ++ show i)) 207 | cleanPs (VarPat (Name n)) 208 | = return $ VarPat (Name n) 209 | cleanPs (VarPat (Generated n i)) 210 | = return $ VarPat (Generated n i) 211 | cleanPs (ConPat c ps') 212 | = ConPat c <$> mapM (\(plic,p) -> do { p' <- cleanPs p ; return (plic,p') }) ps' 213 | cleanPs (AssertionPat m) 214 | = return $ AssertionPat m 215 | cleanPs MakeMeta 216 | = return MakeMeta 217 | 218 | consMotiveHelper :: String -> Term -> CaseMotive -> CaseMotive 219 | consMotiveHelper x a b = CaseMotiveCons a (scope [x] b) 220 | 221 | instance Abstract a Term Term => Abstract a Term (ConSig Term) where 222 | abstract (ConSigNil a) 223 | = ConSigNil <$> abstract a 224 | abstract (ConSigCons plic a sc) 225 | = ConSigCons plic <$> abstract a <*> abstractScope sc 226 | 227 | conSigHelper :: [DeclArg] -> Term -> ConSig Term 228 | conSigHelper [] b = ConSigNil b 229 | conSigHelper (DeclArg plic x a:as) b 230 | = ConSigCons plic a (scope [x] (conSigHelper as b)) 231 | -------------------------------------------------------------------------------- /src/Poly/Core/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | module Poly.Core.Parser where 6 | 7 | import Control.Applicative ((<$>),(*>),(<*),(<*>)) 8 | import Control.Monad (guard) 9 | import Data.List (foldl') 10 | import Text.Parsec 11 | import qualified Text.Parsec.Token as Token 12 | 13 | import Abs 14 | import Scope 15 | import Poly.Core.Abstraction 16 | import Poly.Core.Term 17 | import Poly.Core.Type 18 | import Poly.Core.Program 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | -- Language Definition 29 | 30 | languageDef :: Token.LanguageDef st 31 | languageDef = Token.LanguageDef 32 | { Token.commentStart = "{-" 33 | , Token.commentEnd = "-}" 34 | , Token.commentLine = "--" 35 | , Token.nestedComments = True 36 | , Token.identStart = letter <|> char '_' 37 | , Token.identLetter = alphaNum <|> char '_' <|> char '\'' 38 | , Token.opStart = oneOf "" 39 | , Token.opLetter = oneOf "" 40 | , Token.reservedNames = ["data","case","of","end","where","let","forall"] 41 | , Token.reservedOpNames = ["|","->","\\",":","=",".","||"] 42 | , Token.caseSensitive = True 43 | } 44 | 45 | tokenParser = Token.makeTokenParser languageDef 46 | 47 | identifier = Token.identifier tokenParser 48 | reserved = Token.reserved tokenParser 49 | reservedOp = Token.reservedOp tokenParser 50 | parens = Token.parens tokenParser 51 | symbol = Token.symbol tokenParser 52 | 53 | 54 | 55 | 56 | 57 | -- names 58 | 59 | varName = do lookAhead (lower <|> char '_') 60 | identifier 61 | 62 | decName = do lookAhead upper 63 | identifier 64 | 65 | 66 | -- type parsers 67 | 68 | noArgTypeCon = do c <- decName 69 | return $ TyCon c [] 70 | 71 | typeCon = TyCon <$> decName <*> many tyConArg 72 | 73 | funType = do arg <- try $ do 74 | arg <- funLeft 75 | _ <- reservedOp "->" 76 | return arg 77 | ret <- funRight 78 | return $ Fun arg ret 79 | 80 | typeVar = do x <- varName 81 | guard (x /= "_") 82 | return $ TyVar (TyName x) 83 | 84 | forallType = do _ <- reserved "forall" 85 | xs <- many1 varName 86 | _ <- reservedOp "." 87 | b <- forallBody 88 | return $ helperFold forallHelper xs b 89 | 90 | parenType = parens datatype 91 | 92 | tyConArg = parenType <|> noArgTypeCon <|> typeVar 93 | 94 | funLeft = parenType <|> typeCon <|> typeVar 95 | 96 | funRight = funType <|> parenType <|> forallType <|> typeCon <|> typeVar 97 | 98 | forallBody = funType <|> parenType <|> forallType <|> typeCon <|> typeVar 99 | 100 | datatype = funType <|> parenType <|> forallType <|> typeCon <|> typeVar 101 | 102 | 103 | 104 | -- term parsers 105 | 106 | variable = do x <- varName 107 | guard (x /= "_") 108 | return $ Var (Name x) 109 | 110 | annotation = do m <- try $ do 111 | m <- annLeft 112 | _ <- reservedOp ":" 113 | return m 114 | t <- datatype 115 | return $ Ann m t 116 | 117 | lambda = do _ <- reservedOp "\\" 118 | xs <- many1 varName 119 | _ <- reservedOp "->" 120 | b <- lamBody 121 | return $ helperFold lamHelper xs b 122 | 123 | application = do (f,a) <- try $ do 124 | f <- appFun 125 | a <- appArg 126 | return (f,a) 127 | as <- many appArg 128 | return $ foldl' App f (a:as) 129 | 130 | noArgConData = do c <- decName 131 | return $ Con c [] 132 | 133 | conData = do c <- decName 134 | as <- many conArg 135 | return $ Con c as 136 | 137 | varPattern = do x <- varName 138 | return (VarPat (Name x),[x]) 139 | 140 | noArgConPattern = do c <- decName 141 | return $ (ConPat c [], []) 142 | 143 | conPattern = do c <- decName 144 | psxs <- many conPatternArg 145 | let (ps,xs) = unzip psxs 146 | return $ (ConPat c ps, concat xs) 147 | 148 | parenPattern = parens pattern 149 | 150 | conPatternArg = parenPattern <|> noArgConPattern <|> varPattern 151 | 152 | pattern = parenPattern <|> conPattern <|> varPattern 153 | 154 | clause = do psxs <- try $ do 155 | psxs <- pattern `sepBy` reservedOp "||" 156 | _ <- reservedOp "->" 157 | return psxs 158 | b <- term 159 | let ps = map fst psxs 160 | xs = concat (map snd psxs) 161 | return $ clauseHelper ps xs b 162 | 163 | caseExp = do _ <- reserved "case" 164 | m <- caseArg `sepBy` reservedOp "||" 165 | _ <- reserved "of" 166 | _ <- optional (reservedOp "|") 167 | cs <- clause `sepBy` reservedOp "|" 168 | _ <- reserved "end" 169 | return $ Case m cs 170 | 171 | parenTerm = parens term 172 | 173 | annLeft = application <|> parenTerm <|> conData <|> variable 174 | 175 | lamBody = annotation <|> application <|> parenTerm <|> lambda <|> conData <|> caseExp <|> variable 176 | 177 | appFun = parenTerm <|> variable 178 | 179 | appArg = parenTerm <|> noArgConData <|> variable 180 | 181 | conArg = parenTerm <|> noArgConData <|> variable 182 | 183 | caseArg = annotation <|> application <|> parenTerm <|> lambda <|> conData <|> variable 184 | 185 | term = annotation <|> application <|> parenTerm <|> lambda <|> conData <|> caseExp <|> variable 186 | 187 | parseTerm str = case parse (spaces *> term <* eof) "(unknown)" str of 188 | Left e -> Left (show e) 189 | Right p -> Right p 190 | 191 | 192 | 193 | -- program parsers 194 | 195 | eqTermDecl = do (x,t) <- try $ do 196 | _ <- reserved "let" 197 | x <- varName 198 | _ <- reservedOp ":" 199 | t <- datatype 200 | _ <- reservedOp "=" 201 | return (x,t) 202 | m <- term 203 | _ <- reserved "end" 204 | return $ TermDeclaration x t m 205 | 206 | whereTermDecl = do (x,t) <- try $ do 207 | _ <- reserved "let" 208 | x <- varName 209 | _ <- reservedOp ":" 210 | t <- datatype 211 | _ <- reserved "where" 212 | return (x,t) 213 | _ <- optional (reservedOp "|") 214 | preclauses <- patternMatchClause x `sepBy1` reservedOp "|" 215 | _ <- reserved "end" 216 | return $ WhereDeclaration x t preclauses 217 | 218 | 219 | 220 | patternMatchClause x = do _ <- symbol x 221 | psxs <- many patternMatchPattern 222 | _ <- reservedOp "=" 223 | b <- term 224 | let ps = map fst psxs 225 | xs = concat (map snd psxs) 226 | return (ps,xs,b) 227 | 228 | patternMatchPattern = parenPattern <|> noArgConPattern <|> varPattern 229 | 230 | termDecl = eqTermDecl <|> whereTermDecl 231 | 232 | alternative = do c <- decName 233 | as <- many alternativeArg 234 | return (c,as) 235 | 236 | alternativeArg = parenType <|> typeCon <|> typeVar 237 | 238 | typeDecl = do _ <- reserved "data" 239 | tycon <- decName 240 | params <- many varName 241 | alts <- option [] $ do 242 | _ <- reservedOp "=" 243 | alternative `sepBy` reservedOp "|" 244 | _ <- reserved "end" 245 | return $ TypeDeclaration tycon params alts 246 | 247 | statement = TmDecl <$> termDecl 248 | <|> TyDecl <$> typeDecl 249 | 250 | program = Program <$> many statement 251 | 252 | 253 | 254 | parseProgram :: String -> Either String Program 255 | parseProgram str 256 | = case parse (spaces *> program <* eof) "(unknown)" str of 257 | Left e -> Left (show e) 258 | Right p -> Right p -------------------------------------------------------------------------------- /src/Modular/Core/Abstraction.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module Modular.Core.Abstraction where 9 | 10 | import Control.Applicative 11 | import Control.Monad.Reader 12 | import qualified Control.Monad.State as S 13 | 14 | import Abs 15 | import Plicity 16 | import Scope 17 | import Modular.Core.ConSig 18 | import Modular.Core.Term 19 | 20 | instance Abstract a b c => Abstract a b (Plicity,c) where 21 | abstract (plic,x) = (,) plic <$> abstract x 22 | 23 | instance (Abstract a b Pattern, Abstract a b Term) => Abstract a b Clause where 24 | abstract (Clause psc sc) 25 | = Clause <$> abstractScope psc <*> abstractScope sc 26 | 27 | instance Abstract a b Term => Abstract a b CaseMotive where 28 | abstract (CaseMotiveNil a) 29 | = CaseMotiveNil <$> abstract a 30 | abstract (CaseMotiveCons a sc) 31 | = CaseMotiveCons <$> abstract a <*> abstractScope sc 32 | 33 | instance Abstract String Term Term where 34 | abstract (Meta i) 35 | = return $ Meta i 36 | abstract (Var (Name x)) 37 | = reader $ \e -> 38 | case lookup x e of 39 | Nothing -> Var (Name x) 40 | Just m -> m 41 | abstract (Var (Generated x i)) 42 | = return $ Var (Generated x i) 43 | abstract (DottedVar m var) 44 | = return $ DottedVar m var 45 | abstract (Ann m ty) 46 | = Ann <$> abstract m <*> return ty 47 | abstract Type 48 | = return Type 49 | abstract (Fun plic a sc) 50 | = Fun plic <$> abstract a <*> abstractScope sc 51 | abstract (Lam plic sc) 52 | = Lam plic <$> abstractScope sc 53 | abstract (App plic f a) 54 | = App plic <$> abstract f <*> abstract a 55 | abstract (Con c as) 56 | = Con c <$> forM as (\(plic,a) -> do a' <- abstract a ; return (plic,a')) 57 | abstract (Case as t cs) 58 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 59 | 60 | instance Abstract Int Term Term where 61 | abstract (Meta i) 62 | = return $ Meta i 63 | abstract (Var (Name x)) 64 | = return $ Var (Name x) 65 | abstract (Var (Generated x i)) 66 | = reader $ \e -> 67 | case lookup i e of 68 | Nothing -> Var (Generated x i) 69 | Just m -> m 70 | abstract (DottedVar m var) 71 | = return $ DottedVar m var 72 | abstract (Ann m ty) 73 | = Ann <$> abstract m <*> return ty 74 | abstract Type 75 | = return Type 76 | abstract (Fun plic a sc) 77 | = Fun plic <$> abstract a <*> abstractScope sc 78 | abstract (Lam plic sc) 79 | = Lam plic <$> abstractScope sc 80 | abstract (App plic f a) 81 | = App plic <$> abstract f <*> abstract a 82 | abstract (Con c as) 83 | = Con c <$> forM as (\(plic,a) -> do a' <- abstract a ; return (plic,a')) 84 | abstract (Case as t cs) 85 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 86 | 87 | instance Abstract String Variable Term where 88 | abstract (Meta i) 89 | = return $ Meta i 90 | abstract (Var (Name x)) 91 | = reader $ \e -> 92 | case lookup x e of 93 | Nothing -> Var (Name x) 94 | Just y -> Var y 95 | abstract (Var (Generated x i)) 96 | = return $ Var (Generated x i) 97 | abstract (DottedVar m var) 98 | = return $ DottedVar m var 99 | abstract (Ann m ty) 100 | = Ann <$> abstract m <*> return ty 101 | abstract Type 102 | = return Type 103 | abstract (Fun plic a sc) 104 | = Fun plic <$> abstract a <*> abstractScope sc 105 | abstract (Lam plic sc) 106 | = Lam plic <$> abstractScope sc 107 | abstract (App plic f a) 108 | = App plic <$> abstract f <*> abstract a 109 | abstract (Con c as) 110 | = Con c <$> forM as (\(plic,a) -> do a' <- abstract a ; return (plic,a')) 111 | abstract (Case as t cs) 112 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 113 | 114 | instance Abstract Int Variable Term where 115 | abstract (Meta i) 116 | = return $ Meta i 117 | abstract (Var (Name x)) 118 | = return $ Var (Name x) 119 | abstract (Var (Generated x i)) 120 | = reader $ \e -> 121 | case lookup i e of 122 | Nothing -> Var (Generated x i) 123 | Just y -> Var y 124 | abstract (DottedVar m var) 125 | = return $ DottedVar m var 126 | abstract (Ann m ty) 127 | = Ann <$> abstract m <*> return ty 128 | abstract Type 129 | = return Type 130 | abstract (Fun plic a sc) 131 | = Fun plic <$> abstract a <*> abstractScope sc 132 | abstract (Lam plic sc) 133 | = Lam plic <$> abstractScope sc 134 | abstract (App plic f a) 135 | = App plic <$> abstract f <*> abstract a 136 | abstract (Con c as) 137 | = Con c <$> forM as (\(plic,a) -> do a' <- abstract a ; return (plic,a')) 138 | abstract (Case as t cs) 139 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 140 | 141 | instance Abstract String Term Pattern where 142 | abstract (VarPat x) 143 | = return $ VarPat x 144 | abstract (ConPat c ps) 145 | = ConPat c <$> mapM abstract ps 146 | abstract (AssertionPat m) 147 | = AssertionPat <$> abstract m 148 | abstract MakeMeta 149 | = return MakeMeta 150 | 151 | instance Abstract Int Term Pattern where 152 | abstract (VarPat x) 153 | = return $ VarPat x 154 | abstract (ConPat c ps) 155 | = ConPat c <$> mapM abstract ps 156 | abstract (AssertionPat m) 157 | = AssertionPat <$> abstract m 158 | abstract MakeMeta 159 | = return MakeMeta 160 | 161 | instance Abstract String Variable Pattern where 162 | abstract (VarPat (Name x)) 163 | = reader $ \e -> 164 | case lookup x e of 165 | Nothing -> VarPat (Name x) 166 | Just y -> VarPat y 167 | abstract (VarPat (Generated x i)) 168 | = return $ VarPat (Generated x i) 169 | abstract (ConPat c ps) 170 | = ConPat c <$> mapM abstract ps 171 | abstract (AssertionPat m) 172 | = AssertionPat <$> abstract m 173 | abstract MakeMeta 174 | = return MakeMeta 175 | 176 | instance Abstract Int Variable Pattern where 177 | abstract (VarPat (Name x)) 178 | = return $ VarPat (Name x) 179 | abstract (VarPat (Generated x i)) 180 | = reader $ \e -> 181 | case lookup i e of 182 | Nothing -> VarPat (Generated x i) 183 | Just y -> VarPat y 184 | abstract (ConPat c ps) 185 | = ConPat c <$> mapM abstract ps 186 | abstract (AssertionPat m) 187 | = AssertionPat <$> abstract m 188 | abstract MakeMeta 189 | = return MakeMeta 190 | 191 | funHelper :: Plicity -> String -> Term -> Term -> Term 192 | funHelper plic x a b = Fun plic a (scope [x] b) 193 | 194 | lamHelper :: Plicity -> String -> Term -> Term 195 | lamHelper plic x b = Lam plic (scope [x] b) 196 | 197 | clauseHelper :: [Pattern] -> [String] -> Term -> Clause 198 | clauseHelper ps xs b = Clause (scope2 xs cleanedXs cleanedPs) (scope (filter isVar xs) b) 199 | where 200 | cleanedXs = fst (S.runState (mapM cleanXs xs) 0) 201 | 202 | cleanXs :: String -> S.State Int String 203 | cleanXs "_" = do i <- S.get 204 | S.put (i+1) 205 | return $ "$" ++ show i 206 | cleanXs x = return x 207 | 208 | cleanedPs = fst (S.runState (mapM cleanPs ps) 0) 209 | 210 | cleanPs :: Pattern -> S.State Int Pattern 211 | cleanPs (VarPat (Name "_")) 212 | = do i <- S.get 213 | S.put (i+1) 214 | return $ VarPat (Name ("$" ++ show i)) 215 | cleanPs (VarPat (Name n)) 216 | = return $ VarPat (Name n) 217 | cleanPs (VarPat (Generated n i)) 218 | = return $ VarPat (Generated n i) 219 | cleanPs (ConPat c ps') 220 | = ConPat c <$> mapM (\(plic,p) -> do { p' <- cleanPs p ; return (plic,p') }) ps' 221 | cleanPs (AssertionPat m) 222 | = return $ AssertionPat m 223 | cleanPs MakeMeta 224 | = return MakeMeta 225 | 226 | consMotiveHelper :: String -> Term -> CaseMotive -> CaseMotive 227 | consMotiveHelper x a b = CaseMotiveCons a (scope [x] b) 228 | 229 | instance Abstract a Term Term => Abstract a Term (ConSig Term) where 230 | abstract (ConSigNil a) 231 | = ConSigNil <$> abstract a 232 | abstract (ConSigCons plic a sc) 233 | = ConSigCons plic <$> abstract a <*> abstractScope sc 234 | 235 | conSigHelper :: [DeclArg] -> Term -> ConSig Term 236 | conSigHelper [] b = ConSigNil b 237 | conSigHelper (DeclArg plic x a:as) b 238 | = ConSigCons plic a (scope [x] (conSigHelper as b)) -------------------------------------------------------------------------------- /src/Modular/Core/Term.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | 7 | module Modular.Core.Term where 8 | 9 | import Data.List (intercalate,nub) 10 | 11 | import Parens 12 | import Plicity 13 | import Scope 14 | 15 | 16 | 17 | 18 | 19 | -- Used in multiple places 20 | 21 | data DeclArg 22 | = DeclArg Plicity String Term 23 | 24 | instance Show DeclArg where 25 | show (DeclArg Expl x t) = "(" ++ x ++ " : " ++ show t ++ ")" 26 | show (DeclArg Impl x t) = "{" ++ x ++ " : " ++ show t ++ "}" 27 | 28 | 29 | 30 | 31 | -- Terms 32 | 33 | data Variable 34 | = Name String 35 | | Generated String Int 36 | 37 | instance Eq Variable where 38 | Name x == Name y = x == y 39 | Generated _ i == Generated _ j = i == j 40 | _ == _ = False 41 | 42 | data Constructor 43 | = BareCon String 44 | | DottedCon String String 45 | deriving (Eq) 46 | 47 | instance Show Constructor where 48 | show (BareCon con) = con 49 | show (DottedCon m con) = m ++ "." ++ con 50 | 51 | data Term 52 | = Meta Int 53 | | Var Variable 54 | | DottedVar String String 55 | | Ann Term Term 56 | | Type 57 | | Fun Plicity Term (Scope Term Term) 58 | | Lam Plicity (Scope Term Term) 59 | | App Plicity Term Term 60 | | Con Constructor [(Plicity, Term)] 61 | | Case [Term] CaseMotive [Clause] 62 | 63 | data CaseMotive 64 | = CaseMotiveNil Term 65 | | CaseMotiveCons Term (Scope Term CaseMotive) 66 | 67 | data Clause 68 | = Clause (Scope Variable [Pattern]) (Scope Term Term) 69 | 70 | data Pattern 71 | = VarPat Variable 72 | | ConPat Constructor [(Plicity,Pattern)] 73 | | AssertionPat Term 74 | | MakeMeta 75 | 76 | 77 | 78 | 79 | -- Case Motive Length 80 | 81 | caseMotiveLength :: CaseMotive -> Int 82 | caseMotiveLength (CaseMotiveNil _) = 0 83 | caseMotiveLength (CaseMotiveCons _ sc) 84 | = 1 + caseMotiveLength (descope (Var . Name) sc) 85 | 86 | 87 | 88 | 89 | -- Show Instances 90 | 91 | instance Show Variable where 92 | show (Name x) = x 93 | show (Generated x _) = x 94 | 95 | data PatternParenLoc = ExplConPatArg | ImplConPatArg 96 | deriving (Eq) 97 | 98 | instance ParenLoc Pattern where 99 | type Loc Pattern = PatternParenLoc 100 | parenLoc (VarPat _) = [ExplConPatArg,ImplConPatArg] 101 | parenLoc (ConPat _ _) = [ImplConPatArg] 102 | parenLoc (AssertionPat _) = [ExplConPatArg,ImplConPatArg] 103 | parenLoc MakeMeta = [ExplConPatArg,ImplConPatArg] 104 | 105 | instance ParenRec Pattern where 106 | parenRec (VarPat x) 107 | = show x 108 | parenRec (ConPat c []) 109 | = show c 110 | parenRec (ConPat c ps) 111 | = show c ++ " " ++ unwords (map auxConPatArg ps) 112 | where 113 | auxConPatArg :: (Plicity,Pattern) -> String 114 | auxConPatArg (Expl,p) = parenthesize (Just ExplConPatArg) p 115 | auxConPatArg (Impl,p) = "{" ++ parenthesize (Just ImplConPatArg) p ++ "}" 116 | parenRec (AssertionPat m) 117 | = "." ++ parenthesize (Just AssertionPatArg) m 118 | parenRec MakeMeta 119 | = "?makemeta" 120 | 121 | instance Show Pattern where 122 | show p = parenthesize Nothing p 123 | 124 | data TermParenLoc 125 | = RootTerm 126 | | AnnLeft | AnnRight 127 | | FunArg | FunRet 128 | | LamBody | AppLeft | ExplAppRight | ImplAppRight 129 | | ExplConArg | ImplConArg | AssertionPatArg 130 | deriving (Eq) 131 | 132 | instance ParenLoc Term where 133 | type Loc Term = TermParenLoc 134 | parenLoc (Meta _) 135 | = [AnnLeft,FunArg,FunRet,LamBody,AppLeft,ExplAppRight,ImplAppRight,ExplConArg,ImplConArg,AssertionPatArg] 136 | parenLoc (Var _) 137 | = [AnnLeft,FunArg,FunRet,LamBody,AppLeft,ExplAppRight,ImplAppRight,ExplConArg,ImplConArg,AssertionPatArg] 138 | parenLoc (DottedVar _ _) 139 | = [AnnLeft,FunArg,FunRet,LamBody,AppLeft,ExplAppRight,ImplAppRight,ExplConArg,ImplConArg,AssertionPatArg] 140 | parenLoc (Ann _ _) 141 | = [FunArg,FunRet,LamBody,ImplAppRight,ImplConArg] 142 | parenLoc Type 143 | = [AnnLeft,FunArg,FunRet,LamBody,AppLeft,ExplAppRight,ImplAppRight,ExplConArg,ImplConArg,AssertionPatArg] 144 | parenLoc (Fun _ _ _) 145 | = [FunArg,FunRet,LamBody,ImplAppRight,ImplConArg] 146 | parenLoc (Lam _ _) 147 | = [FunArg,FunRet,LamBody,ImplAppRight,ImplConArg] 148 | parenLoc (App _ _ _) 149 | = [FunArg,FunRet,AnnLeft,LamBody,AppLeft,ImplAppRight,ImplConArg] 150 | parenLoc (Con _ []) 151 | = [FunArg,FunRet,AnnLeft,LamBody,AppLeft,ExplAppRight,ImplAppRight,ExplConArg,ImplConArg,AssertionPatArg] 152 | parenLoc (Con _ _) 153 | = [FunArg,FunRet,AnnLeft,LamBody,ImplAppRight,ImplConArg] 154 | parenLoc (Case _ _ _) 155 | = [FunArg,FunRet,LamBody,ImplAppRight,ImplConArg] 156 | 157 | instance ParenRec Term where 158 | parenRec (Meta i) 159 | = "?" ++ show i 160 | parenRec (Var x) 161 | = show x 162 | parenRec (DottedVar m x) 163 | = m ++ "." ++ x 164 | parenRec (Ann m ty) 165 | = parenthesize (Just AnnLeft) m ++ " : " ++ parenthesize (Just AnnRight) ty 166 | parenRec Type 167 | = "Type" 168 | parenRec (Fun plic a sc) 169 | = let a0' = unwords (names sc) ++ " : " ++ parenthesize (Just FunArg) a 170 | a' = case plic of 171 | Expl -> "(" ++ a0' ++ ")" 172 | Impl -> "{" ++ a0' ++ "}" 173 | in a' ++ " -> " 174 | ++ parenthesize (Just FunRet) 175 | (descope (Var . Name) sc) 176 | parenRec (Lam plic sc) 177 | = let n0' = unwords (names sc) 178 | n' = case plic of 179 | Expl -> n0' 180 | Impl -> "{" ++ n0' ++ "}" 181 | in "\\" ++ n' 182 | ++ " -> " ++ parenthesize (Just LamBody) 183 | (descope (Var . Name) sc) 184 | parenRec (App plic f a) 185 | = let a' = case plic of 186 | Expl -> parenthesize (Just ExplAppRight) a 187 | Impl -> "{" ++ parenthesize (Just ImplAppRight) a ++ "}" 188 | in parenthesize (Just AppLeft) f ++ " " ++ a' 189 | parenRec (Con c []) 190 | = show c 191 | parenRec (Con c as) 192 | = let as' = [ case plic of 193 | Expl -> parenthesize (Just ExplConArg) a 194 | Impl -> "{" ++ parenthesize (Just ImplConArg) a ++ "}" 195 | | (plic,a) <- as 196 | ] 197 | in show c ++ " " ++ intercalate " " as' 198 | parenRec (Case ms mot cs) 199 | = "case " ++ intercalate " || " (map (parenthesize Nothing) ms) 200 | ++ " motive " ++ show mot 201 | ++ " of " ++ intercalate " | " (map auxClause cs) ++ " end" 202 | where 203 | auxClause (Clause psc sc) 204 | = intercalate " || " (map show (descope Name psc)) 205 | ++ " -> " ++ parenthesize Nothing 206 | (descope (Var . Name) sc) 207 | 208 | 209 | 210 | instance Show Term where 211 | show t = parenthesize Nothing t 212 | 213 | 214 | 215 | instance Show CaseMotive where 216 | show (CaseMotiveNil ret) = show ret 217 | show (CaseMotiveCons arg sc) 218 | = "(" ++ unwords (names sc) ++ " : " ++ show arg ++ ") || " 219 | ++ show (descope (Var . Name) sc) 220 | 221 | 222 | 223 | patternVars :: Pattern -> [Variable] 224 | patternVars (VarPat v) = [v] 225 | patternVars (ConPat _ ps) = ps >>= (patternVars . snd) 226 | patternVars (AssertionPat _) = [] 227 | patternVars MakeMeta = [] 228 | 229 | metas :: Term -> [Int] 230 | metas x = nub (go x) 231 | where 232 | go (Meta i) = [i] 233 | go (Var _) = [] 234 | go (DottedVar _ _) = [] 235 | go (Ann m t) = go m ++ go t 236 | go Type = [] 237 | go (Fun _ a sc) = go a ++ go (descope (Var . Name) sc) 238 | go (Lam _ sc) = go (descope (Var . Name) sc) 239 | go (App _ f x) = go f ++ metas x 240 | go (Con _ xs) = concat (map (go . snd) xs) 241 | go (Case as mot cs) = concat (map go as) ++ goCaseMotive mot ++ concat (map goClause cs) 242 | 243 | goPat (VarPat _) = [] 244 | goPat (ConPat _ ps) = concat (map (goPat . snd) ps) 245 | goPat (AssertionPat m) = go m 246 | goPat MakeMeta = [] 247 | 248 | goCaseMotive (CaseMotiveNil t) = go t 249 | goCaseMotive (CaseMotiveCons a sc) = go a ++ goCaseMotive (descope (Var . Name) sc) 250 | 251 | goClause (Clause psc sc) = concat (map goPat (descope Name psc)) ++ go (descope (Var . Name) sc) 252 | 253 | termToPattern :: Term -> Pattern 254 | termToPattern (Var x) = VarPat x 255 | termToPattern (Con c xs) = ConPat c [ (plic, termToPattern x) | (plic,x) <- xs ] 256 | termToPattern m = AssertionPat m -------------------------------------------------------------------------------- /src/Record/Core/Abstraction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | module Record.Core.Abstraction where 8 | 9 | import Control.Applicative 10 | import Control.Monad.Reader 11 | import qualified Control.Monad.State as S 12 | 13 | import Abs 14 | import Plicity 15 | import Scope 16 | import Record.Core.ConSig 17 | import Record.Core.Term 18 | 19 | instance Abstract a b c => Abstract a b (Plicity,c) where 20 | abstract (plic,x) = (,) plic <$> abstract x 21 | 22 | instance (Abstract a b Pattern, Abstract a b Term) => Abstract a b Clause where 23 | abstract (Clause psc sc) 24 | = Clause <$> abstractScope psc <*> abstractScope sc 25 | 26 | instance Abstract a b Term => Abstract a b CaseMotive where 27 | abstract (CaseMotiveNil a) 28 | = CaseMotiveNil <$> abstract a 29 | abstract (CaseMotiveCons a sc) 30 | = CaseMotiveCons <$> abstract a <*> abstractScope sc 31 | 32 | instance Abstract a b Term => Abstract a b Telescope where 33 | abstract TelescopeNil 34 | = return TelescopeNil 35 | abstract (TelescopeCons t sc) 36 | = TelescopeCons <$> abstract t <*> abstractScope sc 37 | 38 | instance Abstract String Term Term where 39 | abstract (Meta i) 40 | = return $ Meta i 41 | abstract (Var (Name x)) 42 | = reader $ \e -> 43 | case lookup x e of 44 | Nothing -> Var (Name x) 45 | Just m -> m 46 | abstract (Var (Generated x i)) 47 | = return $ Var (Generated x i) 48 | abstract (DottedVar m var) 49 | = return $ DottedVar m var 50 | abstract (Ann m ty) 51 | = Ann <$> abstract m <*> return ty 52 | abstract Type 53 | = return Type 54 | abstract (Fun plic a sc) 55 | = Fun plic <$> abstract a <*> abstractScope sc 56 | abstract (Lam plic sc) 57 | = Lam plic <$> abstractScope sc 58 | abstract (App plic f a) 59 | = App plic <$> abstract f <*> abstract a 60 | abstract (Con c as) 61 | = Con c <$> forM as (\(plic,a) -> do a' <- abstract a ; return (plic,a')) 62 | abstract (Case as t cs) 63 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 64 | abstract (RecordType tele) 65 | = RecordType <$> abstract tele 66 | abstract (RecordCon fields) 67 | = RecordCon <$> (sequenceA [ (,) x <$> abstract m | (x,m) <- fields ]) 68 | abstract (RecordDot m x) 69 | = RecordDot <$> abstract m <*> pure x 70 | 71 | instance Abstract Int Term Term where 72 | abstract (Meta i) 73 | = return $ Meta i 74 | abstract (Var (Name x)) 75 | = return $ Var (Name x) 76 | abstract (Var (Generated x i)) 77 | = reader $ \e -> 78 | case lookup i e of 79 | Nothing -> Var (Generated x i) 80 | Just m -> m 81 | abstract (DottedVar m var) 82 | = return $ DottedVar m var 83 | abstract (Ann m ty) 84 | = Ann <$> abstract m <*> return ty 85 | abstract Type 86 | = return Type 87 | abstract (Fun plic a sc) 88 | = Fun plic <$> abstract a <*> abstractScope sc 89 | abstract (Lam plic sc) 90 | = Lam plic <$> abstractScope sc 91 | abstract (App plic f a) 92 | = App plic <$> abstract f <*> abstract a 93 | abstract (Con c as) 94 | = Con c <$> forM as (\(plic,a) -> do a' <- abstract a ; return (plic,a')) 95 | abstract (Case as t cs) 96 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 97 | abstract (RecordType tele) 98 | = RecordType <$> abstract tele 99 | abstract (RecordCon fields) 100 | = RecordCon <$> (sequenceA [ (,) x <$> abstract m | (x,m) <- fields ]) 101 | abstract (RecordDot m x) 102 | = RecordDot <$> abstract m <*> pure x 103 | 104 | instance Abstract String Variable Term where 105 | abstract (Meta i) 106 | = return $ Meta i 107 | abstract (Var (Name x)) 108 | = reader $ \e -> 109 | case lookup x e of 110 | Nothing -> Var (Name x) 111 | Just y -> Var y 112 | abstract (Var (Generated x i)) 113 | = return $ Var (Generated x i) 114 | abstract (DottedVar m var) 115 | = return $ DottedVar m var 116 | abstract (Ann m ty) 117 | = Ann <$> abstract m <*> return ty 118 | abstract Type 119 | = return Type 120 | abstract (Fun plic a sc) 121 | = Fun plic <$> abstract a <*> abstractScope sc 122 | abstract (Lam plic sc) 123 | = Lam plic <$> abstractScope sc 124 | abstract (App plic f a) 125 | = App plic <$> abstract f <*> abstract a 126 | abstract (Con c as) 127 | = Con c <$> forM as (\(plic,a) -> do a' <- abstract a ; return (plic,a')) 128 | abstract (Case as t cs) 129 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 130 | abstract (RecordType tele) 131 | = RecordType <$> abstract tele 132 | abstract (RecordCon fields) 133 | = RecordCon <$> (sequenceA [ (,) x <$> abstract m | (x,m) <- fields ]) 134 | abstract (RecordDot m x) 135 | = RecordDot <$> abstract m <*> pure x 136 | 137 | instance Abstract Int Variable Term where 138 | abstract (Meta i) 139 | = return $ Meta i 140 | abstract (Var (Name x)) 141 | = return $ Var (Name x) 142 | abstract (Var (Generated x i)) 143 | = reader $ \e -> 144 | case lookup i e of 145 | Nothing -> Var (Generated x i) 146 | Just y -> Var y 147 | abstract (DottedVar m var) 148 | = return $ DottedVar m var 149 | abstract (Ann m ty) 150 | = Ann <$> abstract m <*> return ty 151 | abstract Type 152 | = return Type 153 | abstract (Fun plic a sc) 154 | = Fun plic <$> abstract a <*> abstractScope sc 155 | abstract (Lam plic sc) 156 | = Lam plic <$> abstractScope sc 157 | abstract (App plic f a) 158 | = App plic <$> abstract f <*> abstract a 159 | abstract (Con c as) 160 | = Con c <$> forM as (\(plic,a) -> do a' <- abstract a ; return (plic,a')) 161 | abstract (Case as t cs) 162 | = Case <$> mapM abstract as <*> abstract t <*> mapM abstract cs 163 | abstract (RecordType tele) 164 | = RecordType <$> abstract tele 165 | abstract (RecordCon fields) 166 | = RecordCon <$> (sequenceA [ (,) x <$> abstract m | (x,m) <- fields ]) 167 | abstract (RecordDot m x) 168 | = RecordDot <$> abstract m <*> pure x 169 | 170 | instance Abstract String Term Pattern where 171 | abstract (VarPat x) 172 | = return $ VarPat x 173 | abstract (ConPat c ps) 174 | = ConPat c <$> mapM abstract ps 175 | abstract (AssertionPat m) 176 | = AssertionPat <$> abstract m 177 | abstract MakeMeta 178 | = return MakeMeta 179 | 180 | instance Abstract Int Term Pattern where 181 | abstract (VarPat x) 182 | = return $ VarPat x 183 | abstract (ConPat c ps) 184 | = ConPat c <$> mapM abstract ps 185 | abstract (AssertionPat m) 186 | = AssertionPat <$> abstract m 187 | abstract MakeMeta 188 | = return MakeMeta 189 | 190 | instance Abstract String Variable Pattern where 191 | abstract (VarPat (Name x)) 192 | = reader $ \e -> 193 | case lookup x e of 194 | Nothing -> VarPat (Name x) 195 | Just y -> VarPat y 196 | abstract (VarPat (Generated x i)) 197 | = return $ VarPat (Generated x i) 198 | abstract (ConPat c ps) 199 | = ConPat c <$> mapM abstract ps 200 | abstract (AssertionPat m) 201 | = AssertionPat <$> abstract m 202 | abstract MakeMeta 203 | = return MakeMeta 204 | 205 | instance Abstract Int Variable Pattern where 206 | abstract (VarPat (Name x)) 207 | = return $ VarPat (Name x) 208 | abstract (VarPat (Generated x i)) 209 | = reader $ \e -> 210 | case lookup i e of 211 | Nothing -> VarPat (Generated x i) 212 | Just y -> VarPat y 213 | abstract (ConPat c ps) 214 | = ConPat c <$> mapM abstract ps 215 | abstract (AssertionPat m) 216 | = AssertionPat <$> abstract m 217 | abstract MakeMeta 218 | = return MakeMeta 219 | 220 | funHelper :: Plicity -> String -> Term -> Term -> Term 221 | funHelper plic x a b = Fun plic a (scope [x] b) 222 | 223 | lamHelper :: Plicity -> String -> Term -> Term 224 | lamHelper plic x b = Lam plic (scope [x] b) 225 | 226 | clauseHelper :: [Pattern] -> [String] -> Term -> Clause 227 | clauseHelper ps xs b = Clause (scope2 xs cleanedXs cleanedPs) (scope (filter isVar xs) b) 228 | where 229 | cleanedXs = fst (S.runState (mapM cleanXs xs) 0) 230 | 231 | cleanXs :: String -> S.State Int String 232 | cleanXs "_" = do i <- S.get 233 | S.put (i+1) 234 | return $ "$" ++ show i 235 | cleanXs x = return x 236 | 237 | cleanedPs = fst (S.runState (mapM cleanPs ps) 0) 238 | 239 | cleanPs :: Pattern -> S.State Int Pattern 240 | cleanPs (VarPat (Name "_")) 241 | = do i <- S.get 242 | S.put (i+1) 243 | return $ VarPat (Name ("$" ++ show i)) 244 | cleanPs (VarPat (Name n)) 245 | = return $ VarPat (Name n) 246 | cleanPs (VarPat (Generated n i)) 247 | = return $ VarPat (Generated n i) 248 | cleanPs (ConPat c ps') 249 | = ConPat c <$> mapM (\(plic,p) -> do { p' <- cleanPs p ; return (plic,p') }) ps' 250 | cleanPs (AssertionPat m) 251 | = return $ AssertionPat m 252 | cleanPs MakeMeta 253 | = return MakeMeta 254 | 255 | consMotiveHelper :: String -> Term -> CaseMotive -> CaseMotive 256 | consMotiveHelper x a b = CaseMotiveCons a (scope [x] b) 257 | 258 | telescopeHelper :: [(String,Term)] -> Telescope 259 | telescopeHelper [] 260 | = TelescopeNil 261 | telescopeHelper ((x,t):xts) 262 | = let tele = telescopeHelper xts 263 | in TelescopeCons t (scope [x] tele) 264 | 265 | instance Abstract a Term Term => Abstract a Term (ConSig Term) where 266 | abstract (ConSigNil a) 267 | = ConSigNil <$> abstract a 268 | abstract (ConSigCons plic a sc) 269 | = ConSigCons plic <$> abstract a <*> abstractScope sc 270 | 271 | conSigHelper :: [DeclArg] -> Term -> ConSig Term 272 | conSigHelper [] b = ConSigNil b 273 | conSigHelper (DeclArg plic x a:as) b 274 | = ConSigCons plic a (scope [x] (conSigHelper as b)) --------------------------------------------------------------------------------