├── .gitmodules ├── Setup.hs ├── src ├── Base │ ├── Void.path │ ├── Unit.path │ ├── Lazy.path │ ├── Fin.path │ ├── Sigma.path │ ├── Bool.path │ ├── Vector.path │ ├── Fix.path │ ├── Maybe.path │ ├── Function.path │ ├── Nat.path │ ├── Either.path │ ├── Pair.path │ └── List.path ├── Path │ ├── Package.hs │ ├── Semiring.hs │ ├── REPL │ │ └── Command.hs │ ├── Usage.hs │ ├── Parser │ │ ├── Package.hs │ │ ├── REPL.hs │ │ ├── Term.hs │ │ └── Module.hs │ ├── Plicity.hs │ ├── Stack.hs │ ├── Span.hs │ ├── CLI.hs │ ├── Syntax.hs │ ├── Name.hs │ ├── Term.hs │ ├── Problem.hs │ ├── Error.hs │ ├── Surface.hs │ ├── Pretty.hs │ ├── Core.hs │ ├── Module.hs │ ├── Elab.hs │ ├── Parser.hs │ ├── Scope.hs │ └── REPL.hs └── Control │ └── Monad │ └── Module.hs ├── pathc └── Main.hs ├── cabal.project ├── test └── Doctest.hs ├── Base.path-package ├── README.md ├── LICENSE ├── CODE_OF_CONDUCT.md └── path.cabal /.gitmodules: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/Base/Void.path: -------------------------------------------------------------------------------- 1 | module Base.Void 2 | 3 | Void 4 | : Type 5 | = { a : Type } -> a; 6 | -------------------------------------------------------------------------------- /pathc/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Main (main) where 3 | 4 | import Path.CLI (main) 5 | -------------------------------------------------------------------------------- /src/Base/Unit.path: -------------------------------------------------------------------------------- 1 | module Base.Unit 2 | 3 | Unit 4 | : Type 5 | = { a : Type } -> a -> a; 6 | 7 | unit 8 | : Unit 9 | = \ a . a; 10 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: path.cabal ../fused-effects/fused-effects.cabal 2 | optional-packages: vendor/*/*.cabal 3 | jobs: $ncpus 4 | package path 5 | ghc-options: -Werror 6 | -------------------------------------------------------------------------------- /src/Base/Lazy.path: -------------------------------------------------------------------------------- 1 | module Base.Lazy 2 | 3 | import Base.Unit; 4 | 5 | Lazy 6 | : Type -> Type 7 | = \ a . Unit -> a; 8 | 9 | force 10 | : { a : Type } -> Lazy a -> a 11 | = \ {_} f . f unit; 12 | -------------------------------------------------------------------------------- /src/Base/Fin.path: -------------------------------------------------------------------------------- 1 | module Base.Fin 2 | 3 | import Base.Nat; 4 | 5 | Fin 6 | : Nat -> Type 7 | = \ n 8 | . { a : Nat -> Type } 9 | -> a (s n) 10 | -> ({ n : Nat } -> a n -> a (s n)) 11 | -> a (s n); 12 | -------------------------------------------------------------------------------- /src/Path/Package.hs: -------------------------------------------------------------------------------- 1 | module Path.Package where 2 | 3 | import Path.Name 4 | 5 | data Package = Package 6 | { packageName :: PackageName 7 | , packageConstraints :: [Constraint] 8 | , packageSources :: [FilePath] 9 | } 10 | deriving (Eq, Ord, Show) 11 | 12 | data Constraint 13 | = Depends PackageName 14 | deriving (Eq, Ord, Show) 15 | -------------------------------------------------------------------------------- /test/Doctest.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( main 3 | ) where 4 | 5 | import System.Environment 6 | import Test.DocTest 7 | 8 | main :: IO () 9 | main = do 10 | args <- getArgs 11 | autogen <- fmap (<> "/build/doctest/autogen") <$> lookupEnv "HASKELL_DIST_DIR" 12 | doctest (maybe id ((:) . ("-i" <>)) autogen ("-isrc" : "--fast" : if null args then ["src"] else args)) 13 | -------------------------------------------------------------------------------- /src/Base/Sigma.path: -------------------------------------------------------------------------------- 1 | module Base.Sigma 2 | 3 | Sigma 4 | : (A : Type) -> (A -> Type) -> Type 5 | = \ A B . { C : Type } -> (( a : A ) -> B a -> C) -> C; 6 | 7 | sigma 8 | : { A : Type } -> { B : A -> Type } -> ( a : A ) -> B a -> Sigma A B 9 | = \ {_} {_} a b {_} f . f a b; 10 | 11 | fst 12 | : { A : Type } -> { B : A -> Type } -> Sigma A B -> A 13 | = \ {A} {_} s . s {A} (\ a _ . a); 14 | -------------------------------------------------------------------------------- /src/Path/Semiring.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | module Path.Semiring where 3 | 4 | class Semigroup r => Semiring r where 5 | (><) :: r -> r -> r 6 | infixr 7 >< 7 | 8 | zero :: Monoid r => r 9 | zero = mempty 10 | 11 | class (Monoid r, Semiring r) => Unital r where 12 | one :: r 13 | 14 | class Semiring r => LeftModule r m | m -> r where 15 | (><<) :: r -> m -> m 16 | infixr 7 ><< 17 | -------------------------------------------------------------------------------- /src/Base/Bool.path: -------------------------------------------------------------------------------- 1 | module Base.Bool 2 | 3 | import Base.Lazy; 4 | 5 | Bool 6 | : Type 7 | = { a : Type } -> a -> a -> a; 8 | 9 | true 10 | : Bool 11 | = \ a _ . a; 12 | 13 | false 14 | : Bool 15 | = \ _ b . b; 16 | 17 | not 18 | : Bool -> Bool 19 | = \ f a b . f b a; 20 | 21 | ifThenElse 22 | : { a : Type } -> Bool -> Lazy a -> Lazy a -> a 23 | = \ {a} c t e . force {a} (c {Lazy a} t e); 24 | -------------------------------------------------------------------------------- /src/Base/Vector.path: -------------------------------------------------------------------------------- 1 | module Base.Vector 2 | 3 | import Base.Nat; 4 | 5 | Vector 6 | : Nat -> Type -> Type 7 | = \ n a 8 | . { x : Nat -> Type } 9 | -> x z 10 | -> ({ n : Nat } -> a -> x n -> x (s n)) 11 | -> x n; 12 | 13 | nil 14 | : { a : Type } -> Vector z a 15 | = \ {_} nil _ . nil; 16 | 17 | cons 18 | : { n : Nat } -> { a : Type } -> a -> Vector n a -> Vector (s n) a 19 | = \ {_} {_} h t {x} nil cons . cons h (t {x} nil cons); 20 | -------------------------------------------------------------------------------- /src/Base/Fix.path: -------------------------------------------------------------------------------- 1 | module Base.Fix 2 | 3 | Alg 4 | : (Type -> Type) -> Type -> Type 5 | = \ f x . { r : Type } -> (r -> x) -> f r -> x; 6 | 7 | Fix 8 | : (Type -> Type) -> Type 9 | = \ f . { x : Type } -> Alg f x -> x; 10 | 11 | fold 12 | : { f : Type -> Type } 13 | -> { x : Type } 14 | -> Alg f x -> Fix f -> x 15 | = \ {_} {x} alg term . term {x} alg; 16 | 17 | in 18 | : { f : Type -> Type } 19 | -> f (Fix f) -> Fix f 20 | = \ {f} syn {x} alg . alg {Fix f} (fold {f} {x} alg) syn; 21 | -------------------------------------------------------------------------------- /src/Path/REPL/Command.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | module Path.REPL.Command where 3 | 4 | import Path.Module 5 | import Path.Name 6 | import Path.Span (Spanned(..)) 7 | import Path.Surface 8 | import Path.Term 9 | 10 | data Command 11 | = Quit 12 | | Help 13 | | TypeOf (Spanned (Term Surface User)) 14 | | Decl (Decl (Term Surface User)) 15 | | Eval (Spanned (Term Surface User)) 16 | | ShowModules 17 | | Reload 18 | | Import (Spanned ModuleName) 19 | | Doc (Spanned ModuleName) 20 | deriving (Eq, Ord, Show) 21 | -------------------------------------------------------------------------------- /Base.path-package: -------------------------------------------------------------------------------- 1 | name: Base 2 | sources: src/Base/Bool.path 3 | , src/Base/Either.path 4 | , src/Base/Fin.path 5 | , src/Base/Fix.path 6 | , src/Base/Function.path 7 | , src/Base/Lazy.path 8 | , src/Base/List.path 9 | , src/Base/Maybe.path 10 | , src/Base/Nat.path 11 | , src/Base/Pair.path 12 | , src/Base/Sigma.path 13 | , src/Base/Unit.path 14 | , src/Base/Vector.path 15 | , src/Base/Void.path 16 | -------------------------------------------------------------------------------- /src/Base/Maybe.path: -------------------------------------------------------------------------------- 1 | module Base.Maybe 2 | 3 | import Base.Bool; 4 | import Base.Function; 5 | 6 | Maybe 7 | : Type -> Type 8 | = \ a . { b : Type } -> b -> (a -> b) -> b; 9 | 10 | just 11 | : { a : Type } -> a -> Maybe a 12 | = \ {_} a {_} _ just . just a; 13 | 14 | nothing 15 | : { a : Type } -> Maybe a 16 | = \ {_} {_} nothing _ . nothing; 17 | 18 | isJust 19 | : { a : Type } -> Maybe a -> Bool 20 | = \ {_} m . m {Bool} false (\ _ . true); 21 | 22 | map 23 | : { a : Type } 24 | -> { b : Type } 25 | -> (a -> b) 26 | -> (Maybe a -> Maybe b) 27 | = \ {_} {b} f m . m {Maybe b} (nothing {b}) (\ a . just {b} (f a)); 28 | -------------------------------------------------------------------------------- /src/Base/Function.path: -------------------------------------------------------------------------------- 1 | module Base.Function 2 | 3 | id 4 | : { a : Type } -> a -> a 5 | = \ {_} a . a; 6 | 7 | const 8 | : { a : Type } -> { b : Type } -> a -> b -> a 9 | = \ {_} {_} a _ . a; 10 | 11 | flip 12 | : { a : Type } -> { b : Type } -> { c : Type } -> (a -> b -> c) -> (b -> a -> c) 13 | = \ {_} {_} {_} f b a . f a b; 14 | 15 | fix 16 | : { a : Type } 17 | -> { b : Type } 18 | -> ((a -> b) -> a -> b) 19 | -> (a -> b) 20 | = \ {a} {b} f . f (fix {a} {b} f); 21 | 22 | compose 23 | : { a : Type } 24 | -> { b : Type } 25 | -> { c : Type } 26 | -> (b -> c) 27 | -> (a -> b) 28 | -> (a -> c) 29 | = \ {_} {_} {_} f g x . f (g x); 30 | -------------------------------------------------------------------------------- /src/Base/Nat.path: -------------------------------------------------------------------------------- 1 | module Base.Nat 2 | 3 | import Base.Fix; 4 | 5 | NatF 6 | : Type -> Type 7 | = \ a . { b : Type } -> b -> (a -> b) -> b; 8 | 9 | zf 10 | : { a : Type } -> NatF a 11 | = \ {_} {_} z _ . z; 12 | 13 | sf 14 | : { a : Type } -> a -> NatF a 15 | = \ {_} a {_} _ s . s a; 16 | 17 | 18 | Nat 19 | : Type 20 | = Fix NatF; 21 | 22 | z 23 | : Nat 24 | = in {NatF} (zf {Nat}); 25 | 26 | s 27 | : Nat -> Nat 28 | = \ n . in {NatF} (sf {Nat} n); 29 | 30 | 31 | iter 32 | : { a : Type } -> a -> (a -> a) -> Nat -> a 33 | = \ {a} z s n . n {a} (\ k f . f z (\ m . s (k m))); 34 | 35 | 36 | plus 37 | : Nat -> Nat -> Nat 38 | = \ m . iter {Nat} m s; 39 | 40 | times 41 | : Nat -> Nat -> Nat 42 | = \ m . iter {Nat} z (plus m); 43 | -------------------------------------------------------------------------------- /src/Path/Usage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | module Path.Usage where 3 | 4 | import Path.Pretty 5 | import Path.Semiring 6 | 7 | data Usage 8 | = Zero 9 | | One 10 | | More 11 | deriving (Eq, Ord, Show) 12 | 13 | instance Semigroup Usage where 14 | Zero <> a = a 15 | a <> Zero = a 16 | _ <> _ = More 17 | 18 | instance Monoid Usage where 19 | mempty = Zero 20 | 21 | instance Semiring Usage where 22 | Zero >< _ = Zero 23 | _ >< Zero = Zero 24 | One >< One = One 25 | _ >< _ = More 26 | 27 | instance Unital Usage where 28 | one = One 29 | 30 | instance Pretty Usage where 31 | pretty Zero = pretty "0" 32 | pretty One = pretty "1" 33 | pretty More = pretty "ω" 34 | 35 | 36 | data Used a 37 | = Usage :@ a 38 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 39 | 40 | infixr 8 :@ 41 | -------------------------------------------------------------------------------- /src/Base/Either.path: -------------------------------------------------------------------------------- 1 | module Base.Either 2 | 3 | Either 4 | : Type -> Type -> Type 5 | = \ l r . { a : Type } -> (l -> a) -> (r -> a) -> a; 6 | 7 | left 8 | : { l : Type } -> { r : Type } -> l -> Either l r 9 | = \ {_} {_} l {_} left _ . left l; 10 | 11 | right 12 | : { l : Type } -> { r : Type } -> r -> Either l r 13 | = \ {_} {_} r {_} _ right . right r; 14 | 15 | 16 | map 17 | : { l : Type } 18 | -> { r : Type } 19 | -> { r' : Type } 20 | -> (r -> r') 21 | -> (Either l r -> Either l r') 22 | = \ {l} {_} {r'} f e . e {Either l r'} (left {l} {r'}) (\ r . right {l} {r'} (f r)); 23 | 24 | bimap 25 | : { l : Type } 26 | -> { r : Type } 27 | -> { l' : Type } 28 | -> { r' : Type } 29 | -> ( l -> l') 30 | -> ( r -> r') 31 | -> (Either l r -> Either l' r') 32 | = \ {_} {_} {l'} {r'} f g e . e {Either l' r'} (\ l . left {l'} {r'} (f l)) (\ r . right {l'} {r'} (g r)); 33 | -------------------------------------------------------------------------------- /src/Path/Parser/Package.hs: -------------------------------------------------------------------------------- 1 | module Path.Parser.Package where 2 | 3 | import Control.Applicative (Alternative(..)) 4 | import Data.List (intercalate) 5 | import Path.Name 6 | import Path.Package 7 | import Text.Parser.Char 8 | import Text.Parser.Combinators 9 | import Text.Parser.Token 10 | import Text.Parser.Token.Highlight 11 | 12 | package :: (Monad m, TokenParsing m) => m Package 13 | package 14 | = Package 15 | <$> field "name" packageName' 16 | <*> pure [] 17 | <*> field "sources" (commaSep1 filePath) 18 | 19 | packageName' :: (Monad m, TokenParsing m) => m PackageName 20 | packageName' = ident (IdentifierStyle "package name" letter (alphaNum <|> oneOf "-_") mempty Identifier ReservedIdentifier) 21 | 22 | filePath :: TokenParsing m => m FilePath 23 | filePath = intercalate "/" <$> token (some (alphaNum <|> char '.') `sepBy1` string "/") 24 | 25 | field :: (Monad m, TokenParsing m) => String -> m a -> m a 26 | field name m = token (string name) *> colon *> m 27 | -------------------------------------------------------------------------------- /src/Base/Pair.path: -------------------------------------------------------------------------------- 1 | module Base.Pair 2 | 3 | Pair 4 | : Type -> Type -> Type 5 | = \ l r . { a : Type } -> (l -> r -> a) -> a; 6 | 7 | pair 8 | : { l : Type } -> { r : Type } -> l -> r -> Pair l r 9 | = \ {_} {_} l r {_} f . f l r; 10 | 11 | fst 12 | : { l : Type } -> { r : Type } -> Pair l r -> l 13 | = \ {l} {_} p . p {l} (\ fst _ . fst); 14 | 15 | snd 16 | : { l : Type } -> { r : Type } -> Pair l r -> r 17 | = \ {_} {r} p . p {r} (\ _ snd . snd); 18 | 19 | 20 | map 21 | : { l : Type } 22 | -> { r : Type } 23 | -> { r' : Type } 24 | -> (r -> r') 25 | -> (Pair l r -> Pair l r') 26 | = \ {l} {_} {r'} f e . e {Pair l r'} (\ l' r . pair {l} {r'} l' (f r)); 27 | 28 | bimap 29 | : { l : Type } 30 | -> { r : Type } 31 | -> { l' : Type } 32 | -> { r' : Type } 33 | -> ( l -> l') 34 | -> ( r -> r') 35 | -> (Pair l r -> Pair l' r') 36 | = \ {_} {_} {l'} {r'} f g e . e {Pair l' r'} (\ l r . pair {l'} {r'} (f l) (g r)); 37 | -------------------------------------------------------------------------------- /src/Base/List.path: -------------------------------------------------------------------------------- 1 | module Base.List 2 | 3 | import Base.Fix; 4 | 5 | ListF 6 | : Type -> Type -> Type 7 | = \ a b . { c : Type } -> c -> (a -> b -> c) -> c; 8 | 9 | nilf 10 | : { a : Type } -> { b : Type } -> ListF a b 11 | = \ {_} {_} {_} nil _ . nil; 12 | 13 | consf 14 | : { a : Type } -> { b : Type } -> a -> b -> ListF a b 15 | = \ {_} {_} a b {_} _ cons . cons a b; 16 | 17 | 18 | List 19 | : Type -> Type 20 | = \ a . Fix (ListF a); 21 | 22 | nil 23 | : { a : Type } -> List a 24 | = \ {a} . in {ListF a} (nilf {a} {List a}); 25 | 26 | cons 27 | : { a : Type } -> a -> List a -> List a 28 | = \ {a} h t . in {ListF a} (consf {a} h {List a} t); 29 | 30 | 31 | append 32 | : { a : Type } -> List a -> List a -> List a 33 | = \ {a} xs ys . xs {List a} (\ k f . f ys (\ x xs . cons {a} x (k xs))); 34 | 35 | 36 | map 37 | : { a : Type } 38 | -> { b : Type } 39 | -> (a -> b) 40 | -> (List a -> List b) 41 | = \ {_} {b} f l . l {List b} (\ k g . g (nil {b}) (\ a as . cons {b} (f a) (k as))); 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `path`: a lambda calculus to explore type-directed program synthesis 2 | 3 | ## Overview 4 | 5 | `path` was initially based on the calculus described in _[A tutorial implementation of a dependently typed lambda calculus][]_. It has been extended with the quantitative type theory described in _[Syntax and Semantics of Quantitative Type Theory][]_. 6 | 7 | [A tutorial implementation of a dependently typed lambda calculus]: https://www.andres-loeh.de/LambdaPi/LambdaPi.pdf 8 | [Syntax and Semantics of Quantitative Type Theory]: https://bentnib.org/quantitative-type-theory.pdf 9 | 10 | 11 | ## Getting started 12 | 13 | Development of `path` typically uses `cabal new-build`: 14 | 15 | ``` 16 | cabal new-build # build the library and pathc 17 | cabal new-repl # load the library in GHCI 18 | ``` 19 | 20 | Path’s REPL can be run from GHCI: 21 | 22 | ```haskell 23 | λ import Path.REPL 24 | λ repl (packageSources basePackage) 25 | λ: … 26 | ``` 27 | 28 | or from the CLI: 29 | 30 | ``` 31 | cabal new-run pathc -- -i src/Base/*.path 32 | ``` 33 | -------------------------------------------------------------------------------- /src/Path/Plicity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | module Path.Plicity where 3 | 4 | import Path.Pretty 5 | import Path.Semiring 6 | 7 | data Plicity = Im | Ex 8 | deriving (Eq, Ord, Show) 9 | 10 | plicity :: (Eq a, Monoid a) => a -> Plicity 11 | plicity a | a == zero = zero 12 | | otherwise = one 13 | 14 | instance Semigroup Plicity where 15 | Ex <> _ = Ex 16 | _ <> Ex = Ex 17 | _ <> _ = Im 18 | 19 | instance Monoid Plicity where 20 | mempty = Im 21 | 22 | instance Semiring Plicity where 23 | Im >< _ = Im 24 | _ >< Im = Im 25 | _ >< _ = Ex 26 | 27 | instance Unital Plicity where 28 | one = Ex 29 | 30 | 31 | prettyPlicity :: Pretty a => Bool -> Plicit a -> Doc 32 | prettyPlicity _ (Im :< a) = prettyBraces True (pretty a) 33 | prettyPlicity True (Ex :< a) = prettyParens True (pretty a) 34 | prettyPlicity _ (_ :< a) = pretty a 35 | 36 | 37 | data Plicit a 38 | = Plicity :< a 39 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 40 | 41 | infixr 6 :< 42 | 43 | instance Pretty a => Pretty (Plicit a) where 44 | pretty = prettyPlicity True 45 | -------------------------------------------------------------------------------- /src/Path/Stack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable, LambdaCase #-} 2 | module Path.Stack where 3 | 4 | import Data.Foldable (toList) 5 | import Path.Pretty 6 | import Prelude hiding (drop, filter, lookup) 7 | 8 | data Stack a = Nil | Stack a :> a 9 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 10 | 11 | infixl 5 :> 12 | 13 | instance Semigroup (Stack a) where 14 | as <> Nil = as 15 | Nil <> bs = bs 16 | as <> (bs :> b) = (as <> bs) :> b 17 | 18 | instance Monoid (Stack a) where 19 | mempty = Nil 20 | mappend = (<>) 21 | 22 | instance Pretty a => Pretty (Stack a) where 23 | pretty = list . toList . fmap pretty 24 | 25 | 26 | find :: (a -> Bool) -> Stack a -> Maybe a 27 | find p = \case 28 | b :> a 29 | | p a -> Just a 30 | | otherwise -> find p b 31 | Nil -> Nothing 32 | 33 | 34 | filter :: (a -> Bool) -> Stack a -> Stack a 35 | filter keep = \case 36 | as :> a 37 | | keep a -> filter keep as :> a 38 | | otherwise -> filter keep as 39 | Nil -> Nil 40 | 41 | drop :: Int -> Stack a -> Stack a 42 | drop n (xs :> _) | n > 0 = drop (pred n) xs 43 | drop _ xs = xs 44 | 45 | head :: Stack a -> a 46 | head (_ :> a) = a 47 | head _ = error "Path.Stack.head: empty stack" 48 | 49 | tail :: Stack a -> Stack a 50 | tail (as :> _) = as 51 | tail _ = error "Path.Stack.tail: empty stack" 52 | -------------------------------------------------------------------------------- /src/Control/Monad/Module.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, QuantifiedConstraints, MultiParamTypeClasses, TypeOperators #-} 2 | module Control.Monad.Module where 3 | 4 | import Control.Carrier.Class 5 | 6 | class (forall g . Functor g => Functor (f g), HFunctor f) => RightModule f where 7 | (>>=*) :: Monad m => f m a -> (a -> m b) -> f m b 8 | infixl 1 >>=* 9 | 10 | instance (RightModule f, RightModule g) => RightModule (f :+: g) where 11 | L l >>=* f = L (l >>=* f) 12 | R r >>=* f = R (r >>=* f) 13 | 14 | 15 | (>=>*) :: (RightModule f, Monad m) => (a -> f m b) -> (b -> m c) -> (a -> f m c) 16 | f >=>* g = \x -> f x >>=* g 17 | 18 | infixl 1 >=>* 19 | 20 | (<=<*) :: (RightModule f, Monad m) => (b -> m c) -> (a -> f m b) -> (a -> f m c) 21 | g <=<* f = \x -> f x >>=* g 22 | 23 | infixl 1 <=<* 24 | 25 | joinr :: (RightModule f, Monad m) => f m (m a) -> f m a 26 | joinr = (>>=* id) 27 | 28 | 29 | class (forall g . Functor g => Functor (f g), HFunctor f) => LeftModule f where 30 | (*>>=) :: Monad m => m a -> (a -> f m b) -> f m b 31 | infixl 1 *>>= 32 | 33 | (*>=>) :: (LeftModule f, Monad m) => (a -> m b) -> (b -> f m c) -> (a -> f m c) 34 | f *>=> g = \x -> f x *>>= g 35 | 36 | infixl 1 *>=> 37 | 38 | (*<=<) :: (LeftModule f, Monad m) => (b -> f m c) -> (a -> m b) -> (a -> f m c) 39 | g *<=< f = \x -> f x *>>= g 40 | 41 | infixl 1 *<=< 42 | 43 | joinl :: (LeftModule f, Monad m) => m (f m a) -> f m a 44 | joinl = (*>>= id) 45 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2018, Rob Rix 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /src/Path/Parser/REPL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Path.Parser.REPL where 3 | 4 | import Control.Applicative (Alternative(..)) 5 | import Control.Carrier.Reader 6 | import Path.Parser 7 | import qualified Path.Parser.Module as M 8 | import Path.Parser.Term 9 | import Path.REPL.Command 10 | import Text.Parser.Char 11 | import Text.Parser.Combinators 12 | import Text.Parser.Token 13 | 14 | command :: (Carrier sig m, Member Parser sig, Member (Reader [String]) sig, Member (Reader FilePath) sig, TokenParsing m) => m (Maybe Command) 15 | typeof, eval, import', doc :: (Carrier sig m, Member Parser sig, Member (Reader [String]) sig, Member (Reader FilePath) sig, TokenParsing m) => m Command 16 | decl :: (Carrier sig m, Member Parser sig, Member (Reader [String]) sig, Member (Reader FilePath) sig, TokenParsing m) => m Command 17 | quit, help, show', reload :: (Monad m, TokenParsing m) => m Command 18 | 19 | command = optional (quit <|> help <|> typeof <|> try decl <|> eval <|> show' <|> reload <|> import' <|> doc) "command; use :? for help" 20 | 21 | quit = Quit <$ token (string ":q") <|> Quit <$ token (string ":quit") "quit" 22 | 23 | help = Help <$ token (string ":h") <|> Help <$ token (string ":?") <|> Help <$ token (string ":help") "help" 24 | 25 | typeof = TypeOf <$ (token (string ":t") <|> token (string ":type")) <*> term "type of" 26 | 27 | decl = Decl <$> M.declaration 28 | 29 | eval = Eval <$> term "term" 30 | 31 | show' = ShowModules <$ token (string ":show") <* token (string "modules") 32 | 33 | reload = Reload <$ token (string ":r") <|> Reload <$ token (string ":reload") "reload" 34 | 35 | import' = Import <$> M.import' 36 | 37 | doc = Doc <$ token (string ":doc") <*> spanned M.moduleName 38 | -------------------------------------------------------------------------------- /src/Path/Span.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable, FlexibleContexts #-} 2 | module Path.Span 3 | ( Span(..) 4 | , Pos(..) 5 | , advancePos 6 | , Excerpt(..) 7 | , Spanned(..) 8 | , unSpanned 9 | , runSpanned 10 | , runInContext 11 | , spanned 12 | , spanIs 13 | ) where 14 | 15 | import Control.Carrier.Reader 16 | 17 | data Span = Span 18 | { spanStart :: {-# UNPACK #-} !Pos 19 | , spanEnd :: {-# UNPACK #-} !Pos 20 | } 21 | deriving (Eq, Ord, Show) 22 | 23 | instance Semigroup Span where 24 | Span s1 e1 <> Span s2 e2 = Span (min s1 s2) (max e1 e2) 25 | 26 | 27 | data Pos = Pos 28 | { posLine :: {-# UNPACK #-} !Int 29 | , posColumn :: {-# UNPACK #-} !Int 30 | } 31 | deriving (Eq, Ord, Show) 32 | 33 | advancePos :: Char -> Pos -> Pos 34 | advancePos '\n' p = Pos (succ (posLine p)) 0 35 | advancePos _ p = p { posColumn = succ (posColumn p) } 36 | 37 | 38 | data Excerpt = Excerpt 39 | { excerptPath :: FilePath 40 | , excerptLine :: String 41 | , excerptSpan :: {-# UNPACK #-} !Span 42 | } 43 | deriving (Eq, Ord, Show) 44 | 45 | instance Semigroup Excerpt where 46 | Excerpt _ l s1 <> Excerpt p _ s2 = Excerpt p l (s1 <> s2) 47 | 48 | 49 | data Spanned a = a :~ Excerpt 50 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 51 | 52 | unSpanned :: Spanned a -> a 53 | unSpanned (a :~ _) = a 54 | 55 | 56 | runSpanned :: Carrier sig m => (a -> ReaderC Excerpt m b) -> Spanned a -> m (Spanned b) 57 | runSpanned f v@(_ :~ s) = runReader s (traverse f v) 58 | 59 | runInContext :: Carrier sig m => (a -> ReaderC c m b) -> (c, a) -> m (c, b) 60 | runInContext f v = runReader (fst v) (traverse f v) 61 | 62 | spanned :: (Carrier sig m, Member (Reader Excerpt) sig) => a -> m (Spanned a) 63 | spanned a = asks (a :~) 64 | 65 | spanIs :: (Carrier sig m, Member (Reader Excerpt) sig) => Spanned (m a) -> m a 66 | spanIs (m :~ s) = local (const s) m 67 | -------------------------------------------------------------------------------- /src/Path/CLI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | module Path.CLI where 3 | 4 | import Control.Carrier.Error.Either (runError) 5 | import Control.Carrier.Lift (runM) 6 | import Control.Monad (join) 7 | import Data.Version (showVersion) 8 | import Options.Applicative as Options 9 | import Path.Error 10 | import Path.Package 11 | import Path.Parser (parseFile, whole) 12 | import Path.Parser.Package as Parser (package) 13 | import Path.Pretty 14 | import Path.REPL 15 | import qualified Paths_path as Library (version) 16 | 17 | main :: IO () 18 | main = join (execParser argumentsParser) 19 | 20 | argumentsParser :: ParserInfo (IO ()) 21 | argumentsParser = info 22 | (version <*> helper <*> options) 23 | ( fullDesc 24 | <> progDesc "Path is a small experiment in quantitative type theory." 25 | <> header "Path - a quantitative, dependently-typed language") 26 | 27 | options :: Parser (IO ()) 28 | options 29 | = flag' (either (prettyPrint @Notice) repl =<<) (short 'i' <> long "interactive" <> help "run interactively") 30 | <*> (pure . Right <$> some source <|> parsePackage <$> strOption (long "package-path" <> metavar "FILE" <> help "source file")) 31 | where parsePackage = fmap (fmap packageSources) . runM . runError . parseFile (whole Parser.package) 32 | 33 | 34 | constraint :: Parser Constraint 35 | constraint = Depends <$> strOption (short 'p' <> long "package" <> help "a package to depend on") 36 | 37 | source :: Parser FilePath 38 | source = strArgument (metavar "FILE" <> help "source file") 39 | 40 | package :: Parser Package 41 | package 42 | = Package 43 | <$> strOption (short 'n' <> long "name" <> help "the name of the package") 44 | <*> many constraint 45 | <*> some source 46 | 47 | versionString :: String 48 | versionString = "pathc version " <> showVersion Library.version 49 | 50 | version :: Options.Parser (a -> a) 51 | version = infoOption versionString (long "version" <> short 'V' <> help "Output version info.") 52 | -------------------------------------------------------------------------------- /src/Path/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable, TypeOperators #-} 2 | module Path.Syntax where 3 | 4 | import Data.Bifoldable 5 | import Data.Bifunctor 6 | import Data.Bitraversable 7 | import Path.Pretty 8 | 9 | data a ::: b = a ::: b 10 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 11 | 12 | instance Bifoldable (:::) where 13 | bifoldMap f g (a ::: b) = f a <> g b 14 | 15 | instance Bifunctor (:::) where 16 | bimap f g (a ::: b) = f a ::: g b 17 | 18 | instance Bitraversable (:::) where 19 | bitraverse f g (a ::: b) = (:::) <$> f a <*> g b 20 | 21 | typedTerm :: a ::: b -> a 22 | typedTerm (a ::: _) = a 23 | 24 | typedType :: a ::: b -> b 25 | typedType (_ ::: t) = t 26 | 27 | infix 7 ::: 28 | 29 | instance (Pretty a, Pretty b) => Pretty (a ::: b) where 30 | pretty (a ::: t) = pretty a <+> cyan colon <+> pretty t 31 | 32 | 33 | data a := b = a := b 34 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 35 | 36 | infix 1 := 37 | 38 | instance Bifoldable (:=) where 39 | bifoldMap f g (a := b) = f a <> g b 40 | 41 | instance Bifunctor (:=) where 42 | bimap f g (a := b) = f a := g b 43 | 44 | instance Bitraversable (:=) where 45 | bitraverse f g (a := b) = (:=) <$> f a <*> g b 46 | 47 | instance (Pretty a, Pretty b) => Pretty (a := b) where 48 | pretty (a := b) = pretty a <+> magenta (pretty "=") <+> pretty b 49 | 50 | 51 | -- | A functor composing two functors on the inside of a bifunctor. Can be used with @-XDerivingVia@ to derive 'Foldable', 'Functor', and 'Traversable' instances given 'Bifoldable', 'Bifunctor', and 'Bitraversable' instances for @p@ respectively. 52 | newtype Comp2 p f g a = Comp2 { unComp2 :: p (f a) (g a) } 53 | 54 | instance (Bifoldable p, Foldable f, Foldable g) => Foldable (Comp2 p f g) where 55 | foldMap f = bifoldMap (foldMap f) (foldMap f) . unComp2 56 | 57 | instance (Bifunctor p, Functor f, Functor g) => Functor (Comp2 p f g) where 58 | fmap f = Comp2 . bimap (fmap f) (fmap f) . unComp2 59 | -------------------------------------------------------------------------------- /src/Path/Parser/Term.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, LambdaCase #-} 2 | module Path.Parser.Term where 3 | 4 | import Control.Applicative (Alternative(..), (<**>)) 5 | import Control.Carrier.Reader 6 | import Path.Name 7 | import Path.Parser as Parser 8 | import Path.Plicity 9 | import Path.Span (Spanned(..), unSpanned) 10 | import Path.Surface (Surface) 11 | import qualified Path.Surface as Surface 12 | import Path.Syntax 13 | import Path.Term 14 | import Text.Parser.Char 15 | import Text.Parser.Combinators 16 | import Text.Parser.Token 17 | 18 | type', var, term, application, piType, functionType, lambda, atom :: (Carrier sig m, Member Parser sig, Member (Reader [String]) sig, Member (Reader FilePath) sig, TokenParsing m) => m (Spanned (Term Surface User)) 19 | 20 | term = functionType 21 | 22 | application = foldl app <$> atom <*> many (spanned (plicit term atom)) "function application" 23 | where app f@(_ :~ s1) (a :~ s2) = (f Surface.$$ a) :~ (s1 <> s2) 24 | 25 | type' = spanned (Surface.type' <$ keyword "Type") 26 | 27 | piType = spanned (do 28 | p :< (v, ty) <- plicit binding (parens binding) <* op "->" 29 | Surface.pi (p :< named (Just v) v ::: ty) <$> functionType) "dependent function type" 30 | where binding = ((,) <$> name <* colon <*> term) 31 | 32 | functionType = spanned (application <**> (flip (Surface.-->) <$ op "->" <*> functionType <|> pure unSpanned)) 33 | <|> piType 34 | 35 | var = spanned (pure <$> name "variable") 36 | 37 | lambda = spanned (unSpanned <$ op "\\" <*> recur) "lambda" 38 | where recur = spanned (Surface.lam' <$> pattern <*> (recur <|> dot *> term)) "lambda" 39 | pattern = plicit binding binding "pattern" 40 | binding = Just <$> name <|> Nothing <$ token (string "_") 41 | 42 | atom = var <|> type' <|> lambda <|> try (parens term) 43 | 44 | plicit :: TokenParsing m => m a -> m a -> m (Plicit a) 45 | plicit a b = (Im :<) <$> braces a <|> (Ex :<) <$> b 46 | 47 | name :: (Monad m, TokenParsing m) => m User 48 | name = identifier "name" 49 | -------------------------------------------------------------------------------- /src/Path/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable, LambdaCase #-} 2 | module Path.Name where 3 | 4 | import Data.List.NonEmpty (NonEmpty (..)) 5 | import qualified Data.Set as Set 6 | import Path.Pretty 7 | import Path.Stack 8 | 9 | un :: Monad m => (t -> Maybe (m (a, t))) -> t -> m (Stack a, t) 10 | un from = unEither (\ t -> maybe (Left t) Right (from t)) 11 | 12 | unEither :: Monad m => (t -> Either b (m (a, t))) -> t -> m (Stack a, b) 13 | unEither from = go Nil 14 | where go names value = case from value of 15 | Right a -> do 16 | (name, body) <- a 17 | go (names :> name) body 18 | Left b -> pure (names, b) 19 | 20 | 21 | type User = String 22 | 23 | 24 | data ModuleName 25 | = ModuleName String 26 | | ModuleName :. String 27 | deriving (Eq, Ord, Show) 28 | 29 | infixl 5 :. 30 | 31 | instance Pretty ModuleName where 32 | pretty = \case 33 | ModuleName s -> pretty s 34 | ss :. s -> pretty ss <> dot <> pretty s 35 | 36 | makeModuleName :: NonEmpty String -> ModuleName 37 | makeModuleName (s:|ss) = foldl (:.) (ModuleName s) ss 38 | 39 | 40 | type PackageName = String 41 | 42 | 43 | data Qualified 44 | = ModuleName :.: User 45 | deriving (Eq, Ord, Show) 46 | 47 | infixl 5 :.: 48 | 49 | instance Pretty Qualified where 50 | pretty (m :.: n) = pretty m <> dot <> pretty n 51 | 52 | 53 | fvs :: (Foldable t, Ord a) => t a -> Set.Set a 54 | fvs = foldMap Set.singleton 55 | 56 | 57 | data Named a b = Named (Ignored a) b 58 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 59 | 60 | named :: a -> b -> Named a b 61 | named = Named . Ignored 62 | 63 | namedName :: Named a b -> a 64 | namedName (Named (Ignored a) _) = a 65 | 66 | namedValue :: Named a b -> b 67 | namedValue (Named _ b) = b 68 | 69 | 70 | newtype Ignored a = Ignored a 71 | deriving (Foldable, Functor, Show, Traversable) 72 | 73 | instance Eq (Ignored a) where _ == _ = True 74 | instance Ord (Ignored a) where compare _ _ = EQ 75 | 76 | unIgnored :: Ignored a -> a 77 | unIgnored (Ignored a) = a 78 | -------------------------------------------------------------------------------- /src/Path/Parser/Module.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, TypeOperators #-} 2 | module Path.Parser.Module where 3 | 4 | import Control.Applicative (Alternative(..)) 5 | import Control.Effect 6 | import Control.Monad.IO.Class 7 | import Path.Error (Notice) 8 | import qualified Path.Module as Module 9 | import Path.Name 10 | import Path.Parser 11 | import Path.Parser.Term 12 | import Path.Span (Spanned(..)) 13 | import Path.Surface 14 | import Path.Term 15 | import Text.Parser.Char 16 | import Text.Parser.Combinators 17 | import Text.Parser.Token 18 | 19 | parseModule :: (Carrier sig m, Effect sig, Member (Error Notice) sig, MonadIO m) => FilePath -> m (Module.Module (Term Surface) User) 20 | parseModule path = parseFile (whole (module' path)) path 21 | 22 | 23 | module' :: (Carrier sig m, Member Parser sig, Member (Reader [String]) sig, Member (Reader FilePath) sig, TokenParsing m) => FilePath -> m (Module.Module (Term Surface) User) 24 | module' path = make <$> optional docs <* keyword "module" <*> moduleName <*> many (try import') <*> many declaration 25 | where make comment name = Module.module' name comment path 26 | 27 | moduleName :: (Monad m, TokenParsing m) => m ModuleName 28 | moduleName = makeModuleName <$> token (runUnspaced (identifier `sepByNonEmpty` dot)) 29 | 30 | import' :: (Carrier sig m, Member Parser sig, Member (Reader [String]) sig, Member (Reader FilePath) sig, TokenParsing m) => m (Spanned ModuleName) 31 | import' = spanned (keyword "import" *> moduleName) <* semi 32 | 33 | declaration :: (Carrier sig m, Member Parser sig, Member (Reader [String]) sig, Member (Reader FilePath) sig, TokenParsing m) => m (Module.Decl (Term Surface User)) 34 | declaration = do 35 | docs <- optional docs 36 | name <- name 37 | ty <- op ":" *> term 38 | tm <- op "=" *> term 39 | Module.Decl name docs tm ty <$ semi 40 | 41 | docs :: TokenParsing m => m String 42 | docs = runUnlined (fmap unlines . (:) <$> firstLine <*> many line) 43 | where firstLine = string "--" *> whiteSpace *> char '|' *> whiteSpace *> many (satisfy (/= '\n')) <* newline 44 | line = string "--" *> whiteSpace *> many (satisfy (/= '\n')) <* newline 45 | -------------------------------------------------------------------------------- /src/Path/Term.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable, FlexibleInstances, LambdaCase, MultiParamTypeClasses, QuantifiedConstraints, RankNTypes, ScopedTypeVariables, StandaloneDeriving, UndecidableInstances #-} 2 | module Path.Term where 3 | 4 | import Control.Carrier.Class 5 | import Control.Monad (ap) 6 | import Control.Monad.Module 7 | import Path.Pretty 8 | import Path.Scope 9 | 10 | data Term sig a 11 | = Var a 12 | | Term (sig (Term sig) a) 13 | 14 | deriving instance ( Eq a 15 | , RightModule sig 16 | , forall g x . (Eq x, Monad g, forall y . Eq y => Eq (g y)) => Eq (sig g x) 17 | ) 18 | => Eq (Term sig a) 19 | deriving instance ( Ord a 20 | , RightModule sig 21 | , forall g x . (Eq x, Monad g, forall y . Eq y => Eq (g y)) => Eq (sig g x) 22 | , forall g x . (Ord x, Monad g, forall y . Eq y => Eq (g y) 23 | , forall y . Ord y => Ord (g y)) => Ord (sig g x) 24 | ) 25 | => Ord (Term sig a) 26 | deriving instance (Show a, forall g x . (Show x, forall y . Show y => Show (g y)) => Show (sig g x)) => Show (Term sig a) 27 | 28 | deriving instance ( forall g . Foldable g => Foldable (sig g)) => Foldable (Term sig) 29 | deriving instance ( forall g . Functor g => Functor (sig g)) => Functor (Term sig) 30 | deriving instance ( forall g . Foldable g => Foldable (sig g) 31 | , forall g . Functor g => Functor (sig g) 32 | , forall g . Traversable g => Traversable (sig g)) => Traversable (Term sig) 33 | 34 | instance RightModule sig => Applicative (Term sig) where 35 | pure = Var 36 | (<*>) = ap 37 | 38 | instance RightModule sig => Monad (Term sig) where 39 | Var a >>= f = f a 40 | Term t >>= f = Term (t >>=* f) 41 | 42 | instance RightModule sig => Carrier sig (Term sig) where 43 | eff = Term 44 | 45 | 46 | prettyTerm 47 | :: forall sig a 48 | . (forall g . Foldable g => Foldable (sig g), Pretty a, RightModule sig) 49 | => (forall f n . (Foldable f, Monad f) => (forall n . Vec n Doc -> f (Var (Fin n) a) -> Prec) -> Vec n Doc -> sig f (Var (Fin n) a) -> Prec) 50 | -> Term sig a 51 | -> Doc 52 | prettyTerm alg = precDoc . prettyTermInContext alg VZ . fmap F 53 | 54 | prettyTermInContext 55 | :: forall sig n a 56 | . (forall g . Foldable g => Foldable (sig g), Pretty a, RightModule sig) 57 | => (forall f n . (Foldable f, Monad f) => (forall n . Vec n Doc -> f (Var (Fin n) a) -> Prec) -> Vec n Doc -> sig f (Var (Fin n) a) -> Prec) 58 | -> Vec n Doc 59 | -> Term sig (Var (Fin n) a) 60 | -> Prec 61 | prettyTermInContext alg = go 62 | where go :: forall n . Vec n Doc -> Term sig (Var (Fin n) a) -> Prec 63 | go ctx = \case 64 | Var v -> atom (var (ctx !) pretty v) 65 | Term t -> alg go ctx t 66 | -------------------------------------------------------------------------------- /src/Path/Problem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, QuantifiedConstraints, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} 2 | module Path.Problem where 3 | 4 | import Control.Applicative (Alternative (..)) 5 | import Control.Carrier.Class 6 | import Control.Monad.Module 7 | import GHC.Generics (Generic1) 8 | import Path.Core 9 | import Path.Pretty 10 | import Path.Scope 11 | import Path.Syntax 12 | import Path.Term 13 | import Prelude hiding (pi) 14 | 15 | -- FIXME: represent errors explicitly in the tree 16 | -- FIXME: represent spans explicitly in the tree 17 | data Problem f a 18 | = Ex (f a) (Scope () f a) 19 | | f a :===: f a 20 | deriving (Foldable, Functor, Generic1, HFunctor, Traversable) 21 | 22 | infix 3 :===: 23 | 24 | deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Problem f a) 25 | deriving instance (Ord a, forall a . Eq a => Eq (f a) 26 | , forall a . Ord a => Ord (f a), Monad f) => Ord (Problem f a) 27 | deriving instance (Show a, forall a . Show a => Show (f a)) => Show (Problem f a) 28 | 29 | instance RightModule Problem where 30 | Ex t b >>=* f = Ex (t >>= f) (b >>=* f) 31 | p :===: q >>=* f = (p >>= f) :===: (q >>= f) 32 | 33 | 34 | exists :: (Eq a, Carrier sig m, Member Problem sig) => a ::: m a -> m a -> m a 35 | exists (n ::: t) b = send (Ex t (bind1 n b)) 36 | 37 | existsFin :: (Carrier sig m, Member Problem sig) => m (Var (Fin n) a) -> m (Var (Fin ('S n)) a) -> m (Var (Fin n) a) 38 | existsFin t b = send (Ex t (toScopeFin b)) 39 | 40 | unexists :: (Alternative m, Member Problem sig, RightModule sig) => a -> Term sig a -> m (a ::: Term sig a, Term sig a) 41 | unexists n (Term t) | Just (Ex t b) <- prj t = pure (n ::: t, instantiate1 (pure n) b) 42 | unexists _ _ = empty 43 | 44 | (===) :: (Carrier sig m, Member Problem sig) => m a -> m a -> m a 45 | p === q = send (p :===: q) 46 | 47 | infixr 3 === 48 | 49 | 50 | instance Pretty a => Pretty (Term (Problem :+: Core) a) where 51 | pretty = prettyTerm (\ go ctx -> \case 52 | L p -> prettyProblem go ctx p 53 | R c -> prettyCore go ctx c) 54 | 55 | prettyProblem 56 | :: Monad f 57 | => (forall n . Vec n Doc -> f (Var (Fin n) a) -> Prec) 58 | -> Vec n Doc 59 | -> Problem f (Var (Fin n) a) 60 | -> Prec 61 | prettyProblem go ctx = \case 62 | Ex t b -> 63 | let t' = withPrec 1 (go ctx t) 64 | n = prettyMeta (prettyVar (length ctx)) 65 | b' = withPrec 0 (go (VS n ctx) (fromScopeFin b)) 66 | in prec 0 (group (vsep [magenta (pretty "∃") <+> pretty (n ::: t'), magenta dot <+> b'])) 67 | p1 :===: p2 -> 68 | let p1' = withPrec 1 (go ctx p1) 69 | p2' = withPrec 1 (go ctx p2) 70 | in prec 0 (flatAlt (p1' <+> eq' <+> p2') (align (group (vsep [space <+> p1', eq' <+> p2'])))) 71 | where eq' = magenta (pretty "≡") 72 | -------------------------------------------------------------------------------- /src/Path/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Path.Error where 3 | 4 | import Control.Carrier.Error.Either 5 | import Control.Carrier.Reader 6 | import Data.Foldable (fold, toList) 7 | import Data.List (isSuffixOf) 8 | import Data.List.NonEmpty (NonEmpty(..)) 9 | import qualified Data.Set as Set 10 | import Path.Name 11 | import Path.Pretty 12 | import Path.Span 13 | 14 | data Level 15 | = Warn 16 | | Error 17 | deriving (Eq, Ord, Show) 18 | 19 | instance Pretty Level where 20 | pretty Warn = magenta (pretty "warning") 21 | pretty Error = red (pretty "error") 22 | 23 | 24 | data Notice = Notice 25 | { noticeLevel :: Maybe Level 26 | , noticeExcerpt :: {-# UNPACK #-} !Excerpt 27 | , noticeReason :: Doc 28 | , noticeContext :: [Doc] 29 | } 30 | deriving (Show) 31 | 32 | instance Pretty Notice where 33 | pretty (Notice level (Excerpt path line span) reason context) = vsep 34 | ( nest 2 (group (vsep [bold (pretty path) <> colon <> bold (pretty (succ (posLine (spanStart span)))) <> colon <> bold (pretty (succ (posColumn (spanStart span)))) <> colon <> maybe mempty ((space <>) . (<> colon) . pretty) level, reason])) 35 | : blue (pretty (succ (posLine (spanStart span)))) <+> align (fold 36 | [ blue (pretty '|') <+> pretty line <> if "\n" `isSuffixOf` line then mempty else blue (pretty "") <> hardline 37 | , blue (pretty '|') <+> caret span 38 | ]) 39 | : context) 40 | where caret span = pretty (replicate (posColumn (spanStart span)) ' ') <> prettySpan span 41 | 42 | 43 | freeVariables :: (Carrier sig m, Member (Error Notice) sig, Member (Reader Excerpt) sig, Ord name, Pretty name) => NonEmpty name -> m a 44 | freeVariables names = do 45 | span <- ask 46 | throwError (Notice (Just Error) span (pretty "free variable" <> (if length names == 1 then mempty else pretty "s") <+> fillSep (punctuate comma (map pretty (toList (foldMap Set.singleton names))))) []) 47 | 48 | ambiguousName :: (Carrier sig m, Member (Error Notice) sig, Member (Reader Excerpt) sig) => User -> NonEmpty Qualified -> m a 49 | ambiguousName name sources = do 50 | span <- ask 51 | throwError $ Notice (Just Error) span (pretty "ambiguous name" <+> squotes (pretty name)) [nest 2 (vsep 52 | ( pretty "it could refer to" 53 | : map pretty (toList sources)))] 54 | 55 | 56 | unknownModule :: (Carrier sig m, Member (Error Notice) sig) => Spanned ModuleName -> m a 57 | unknownModule (name :~ excerpt) = throwError (Notice (Just Error) excerpt (pretty "Could not find module" <+> squotes (pretty name)) []) 58 | 59 | cyclicImport :: (Carrier sig m, Member (Error Notice) sig) => NonEmpty (Spanned ModuleName) -> m a 60 | cyclicImport (name :~ span :| []) = throwError (Notice (Just Error) span (pretty "Cyclic import of" <+> squotes (pretty name)) []) 61 | cyclicImport (name :~ span :| names) = throwError (Notice (Just Error) span (pretty "Cyclic import of" <+> squotes (pretty name) <> colon) (foldr ((:) . whichImports) [ whichImports (name :~ span) ] names)) 62 | where whichImports (name :~ excerpt) = pretty (Notice Nothing excerpt (pretty "which imports" <+> squotes (pretty name) <> colon) []) 63 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | In the interest of fostering an open and welcoming environment, we as 6 | contributors and maintainers pledge to making participation in our project and 7 | our community a harassment-free experience for everyone, regardless of age, body 8 | size, disability, ethnicity, gender identity and expression, level of experience, 9 | education, socio-economic status, nationality, personal appearance, race, 10 | religion, or sexual identity and orientation. 11 | 12 | ## Our Standards 13 | 14 | Examples of behavior that contributes to creating a positive environment 15 | include: 16 | 17 | * Using welcoming and inclusive language 18 | * Being respectful of differing viewpoints and experiences 19 | * Gracefully accepting constructive criticism 20 | * Focusing on what is best for the community 21 | * Showing empathy towards other community members 22 | 23 | Examples of unacceptable behavior by participants include: 24 | 25 | * The use of sexualized language or imagery and unwelcome sexual attention or 26 | advances 27 | * Trolling, insulting/derogatory comments, and personal or political attacks 28 | * Public or private harassment 29 | * Publishing others' private information, such as a physical or electronic 30 | address, without explicit permission 31 | * Other conduct which could reasonably be considered inappropriate in a 32 | professional setting 33 | 34 | ## Our Responsibilities 35 | 36 | Project maintainers are responsible for clarifying the standards of acceptable 37 | behavior and are expected to take appropriate and fair corrective action in 38 | response to any instances of unacceptable behavior. 39 | 40 | Project maintainers have the right and responsibility to remove, edit, or 41 | reject comments, commits, code, wiki edits, issues, and other contributions 42 | that are not aligned to this Code of Conduct, or to ban temporarily or 43 | permanently any contributor for other behaviors that they deem inappropriate, 44 | threatening, offensive, or harmful. 45 | 46 | ## Scope 47 | 48 | This Code of Conduct applies both within project spaces and in public spaces 49 | when an individual is representing the project or its community. Examples of 50 | representing a project or community include using an official project e-mail 51 | address, posting via an official social media account, or acting as an appointed 52 | representative at an online or offline event. Representation of a project may be 53 | further defined and clarified by project maintainers. 54 | 55 | ## Enforcement 56 | 57 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 58 | reported by contacting the project team at [INSERT EMAIL ADDRESS]. All 59 | complaints will be reviewed and investigated and will result in a response that 60 | is deemed necessary and appropriate to the circumstances. The project team is 61 | obligated to maintain confidentiality with regard to the reporter of an incident. 62 | Further details of specific enforcement policies may be posted separately. 63 | 64 | Project maintainers who do not follow or enforce the Code of Conduct in good 65 | faith may face temporary or permanent repercussions as determined by other 66 | members of the project's leadership. 67 | 68 | ## Attribution 69 | 70 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, 71 | available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html 72 | 73 | [homepage]: https://www.contributor-covenant.org 74 | -------------------------------------------------------------------------------- /src/Path/Surface.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveTraversable, DerivingStrategies, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, QuantifiedConstraints, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} 2 | module Path.Surface where 3 | 4 | import Control.Applicative 5 | import Control.Carrier.Class 6 | import Control.Monad (join) 7 | import Control.Monad.Module 8 | import Control.Monad.Trans 9 | import GHC.Generics (Generic1) 10 | import Path.Name 11 | import Path.Plicity 12 | import Path.Scope 13 | import Path.Span 14 | import Path.Syntax 15 | import Path.Term 16 | 17 | data Surface f a 18 | = Lam (Plicit (Ignored (Maybe User))) (Spanned (Scope () f a)) 19 | | Spanned (f a) :$ Plicit (Spanned (f a)) 20 | | Type 21 | | Pi (Plicit (Ignored (Maybe User) ::: Spanned (f a))) (Spanned (Scope () f a)) 22 | deriving (Foldable, Functor, Generic1, HFunctor, Traversable) 23 | 24 | deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Surface f a) 25 | deriving instance (Ord a, forall a . Eq a => Eq (f a) 26 | , forall a . Ord a => Ord (f a), Monad f) => Ord (Surface f a) 27 | deriving instance (Show a, forall a . Show a => Show (f a)) => Show (Surface f a) 28 | 29 | instance RightModule Surface where 30 | Lam p b >>=* f = Lam p (fmap (>>=* f) b) 31 | g :$ a >>=* f = (fmap (>>= f) g) :$ (fmap (fmap (>>= f)) a) 32 | Type >>=* _ = Type 33 | Pi t b >>=* f = Pi (fmap (fmap (fmap (>>= f))) t) (fmap (>>=* f) b) 34 | 35 | newtype SurfaceC m a = SurfaceC { runSurfaceC :: m (Term Surface a) } 36 | deriving (Functor) 37 | 38 | instance Applicative m => Applicative (SurfaceC m) where 39 | pure = SurfaceC . pure . Var 40 | SurfaceC f <*> SurfaceC a = SurfaceC (liftA2 (<*>) f a) 41 | 42 | instance Monad m => Monad (SurfaceC m) where 43 | -- FIXME: is this valid? 44 | SurfaceC m >>= f = SurfaceC (m >>= fmap join . traverse (runSurfaceC . f)) 45 | 46 | instance (Carrier sig m, Effect sig) => Carrier (Surface :+: sig) (SurfaceC m) where 47 | eff (L s) = SurfaceC . fmap Term $ case s of 48 | f :$ a -> (:$) <$> traverse runSurfaceC f <*> traverse (traverse runSurfaceC) a 49 | Lam p b -> Lam p <$> traverse recur b 50 | Type -> pure Type 51 | Pi t b -> Pi <$> traverse (traverse (traverse runSurfaceC)) t <*> traverse recur b 52 | where recur = fmap Scope . (>>= traverse (traverse runSurfaceC)) . runSurfaceC . unScope 53 | -- FIXME: is this valid? 54 | eff (R other) = SurfaceC (eff (handle (Var ()) (fmap join . traverse runSurfaceC) other)) 55 | 56 | 57 | lam :: (Eq a, Carrier sig m, Member Surface sig) => Plicit (Named (Maybe User) a) -> Spanned (m a) -> m a 58 | lam (p :< Named u n) b = send (Lam (p :< u) (bind1 n <$> b)) 59 | 60 | lam' :: (Carrier sig m, Member Surface sig) => Plicit (Maybe User) -> Spanned (m User) -> m User 61 | lam' (p :< Nothing) b = send (Lam (p :< Ignored Nothing) (lift <$> b)) 62 | lam' (p :< Just n) b = lam (p :< named (Just n) n) b 63 | 64 | ($$) :: (Carrier sig m, Member Surface sig) => Spanned (m a) -> Plicit (Spanned (m a)) -> m a 65 | f $$ a = send (f :$ a) 66 | 67 | 68 | type' :: (Carrier sig m, Member Surface sig) => m a 69 | type' = send Type 70 | 71 | pi :: (Eq a, Carrier sig m, Member Surface sig) => Plicit (Named (Maybe User) a ::: Spanned (m a)) -> Spanned (m a) -> m a 72 | pi (p :< Named u n ::: t) b = send (Pi (p :< u ::: t) (bind1 n <$> b)) 73 | 74 | (-->) :: (Carrier sig m, Member Surface sig) => Spanned (m a) -> Spanned (m a) -> m a 75 | t --> b = send (Pi (Ex :< Ignored Nothing ::: t) (lift <$> b)) 76 | 77 | infixr 0 --> 78 | -------------------------------------------------------------------------------- /path.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | 3 | name: path 4 | version: 0.1.0.0 5 | -- synopsis: 6 | -- description: 7 | license: BSD-3-Clause 8 | license-file: LICENSE 9 | author: Rob Rix 10 | maintainer: rob.rix@me.com 11 | copyright: 2018 Rob Rix 12 | category: Language 13 | build-type: Simple 14 | extra-source-files: README.md 15 | 16 | library 17 | exposed-modules: Control.Monad.Module 18 | , Path.CLI 19 | , Path.Core 20 | , Path.Elab 21 | , Path.Error 22 | , Path.Module 23 | , Path.Name 24 | , Path.Package 25 | , Path.Parser 26 | , Path.Parser.Module 27 | , Path.Parser.Package 28 | , Path.Parser.REPL 29 | , Path.Parser.Term 30 | , Path.Plicity 31 | , Path.Pretty 32 | , Path.Problem 33 | , Path.REPL 34 | , Path.REPL.Command 35 | , Path.Scope 36 | , Path.Semiring 37 | , Path.Span 38 | , Path.Stack 39 | , Path.Surface 40 | , Path.Syntax 41 | , Path.Term 42 | , Path.Usage 43 | other-modules: Paths_path 44 | -- other-extensions: 45 | build-depends: base >=4.11 && <4.13 46 | , bytestring 47 | , containers 48 | , directory 49 | , filepath 50 | , fused-effects ^>= 0.5 51 | , haskeline 52 | , mtl 53 | , optparse-applicative 54 | , parsers 55 | , prettyprinter 56 | , prettyprinter-ansi-terminal 57 | , terminal-size 58 | , text 59 | , unordered-containers 60 | hs-source-dirs: src 61 | default-language: Haskell2010 62 | ghc-options: -Weverything -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-name-shadowing -Wno-monomorphism-restriction -Wno-missed-specialisations -Wno-all-missed-specialisations 63 | if (impl(ghc >= 8.4)) 64 | ghc-options: -Wno-missing-export-lists 65 | if (impl(ghc >= 8.6)) 66 | ghc-options: -Wno-star-is-type 67 | 68 | executable pathc 69 | main-is: Main.hs 70 | build-depends: path 71 | hs-source-dirs: pathc 72 | default-language: Haskell2010 73 | ghc-options: -Weverything -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-name-shadowing -Wno-monomorphism-restriction -Wno-missed-specialisations -Wno-all-missed-specialisations 74 | if (impl(ghc >= 8.4)) 75 | ghc-options: -Wno-missing-export-lists 76 | if (impl(ghc >= 8.6)) 77 | ghc-options: -Wno-star-is-type 78 | 79 | 80 | test-suite doctest 81 | type: exitcode-stdio-1.0 82 | main-is: Doctest.hs 83 | build-depends: base >=4.9 && <4.13 84 | , doctest >=0.7 && <1.0 85 | , path 86 | , QuickCheck 87 | hs-source-dirs: test 88 | default-language: Haskell2010 89 | 90 | 91 | source-repository head 92 | type: git 93 | location: https://github.com/robrix/path 94 | -------------------------------------------------------------------------------- /src/Path/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures, FlexibleInstances #-} 2 | module Path.Pretty 3 | ( 4 | -- * Styled pretty-printing class 5 | Doc 6 | , Pretty(..) 7 | -- * Output 8 | , prettyPrint 9 | , putDoc 10 | -- * Combinators 11 | , prettyVar 12 | , prettyMeta 13 | , prettySpan 14 | , tabulate2 15 | , prettyParens 16 | , prettyBraces 17 | -- * Foreground colours 18 | , red 19 | , yellow 20 | , green 21 | , cyan 22 | , blue 23 | , magenta 24 | -- * Foreground colours (dull) 25 | , dullblack 26 | -- * Styling 27 | , bold 28 | , plain 29 | -- * Debugging 30 | , tracePrettyM 31 | -- * Pretty-printing with precedence 32 | , Prec(..) 33 | , prec 34 | , atom 35 | , withPrec 36 | , module PP 37 | ) where 38 | 39 | import Control.Arrow ((***)) 40 | import Control.Monad.IO.Class 41 | import Path.Span 42 | import System.Console.Terminal.Size as Size 43 | import System.IO (stdout) 44 | import System.IO.Unsafe 45 | import qualified Data.Text as Text 46 | import Data.Text.Prettyprint.Doc as PP hiding (Doc, Pretty (..), column) 47 | import qualified Data.Text.Prettyprint.Doc as PP 48 | import Data.Text.Prettyprint.Doc.Internal (unsafeTextWithoutNewlines) 49 | import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle, Color (..), color, colorDull) 50 | import qualified Data.Text.Prettyprint.Doc.Render.Terminal as ANSI 51 | 52 | type Doc = PP.Doc AnsiStyle 53 | 54 | class Pretty a where 55 | pretty :: a -> Doc 56 | default pretty :: PP.Pretty a => a -> Doc 57 | pretty = PP.pretty 58 | 59 | prettyList :: [a] -> Doc 60 | prettyList = align . list . map pretty 61 | 62 | instance Pretty Char where 63 | prettyList = pretty . Text.pack 64 | 65 | instance Pretty Text.Text where pretty = vsep . map unsafeTextWithoutNewlines . Text.splitOn (Text.pack "\n") 66 | instance Pretty (PP.Doc AnsiStyle) where pretty = id 67 | instance Pretty Int 68 | instance Pretty a => Pretty [a] where 69 | pretty = prettyList 70 | 71 | prettyPrint :: (Pretty a, MonadIO m) => a -> m () 72 | prettyPrint = putDoc . pretty 73 | 74 | putDoc :: MonadIO m => Doc -> m () 75 | putDoc doc = do 76 | s <- maybe 80 Size.width <$> liftIO size 77 | liftIO (ANSI.renderIO stdout (layoutSmart defaultLayoutOptions { layoutPageWidth = AvailablePerLine s 0.8 } (doc <> line))) 78 | 79 | 80 | prettyVar :: Int -> Doc 81 | prettyVar i = pretty (alphabet !! r : if q > 0 then show q else "") 82 | where (q, r) = i `divMod` 26 83 | alphabet = ['a'..'z'] 84 | 85 | prettyMeta :: Pretty a => a -> Doc 86 | prettyMeta n = dullblack (bold (pretty '?' <> pretty n)) 87 | 88 | 89 | prettySpan :: Span -> Doc 90 | prettySpan (Span start end) 91 | | start == end = green (pretty '^') 92 | | posLine start == posLine end = green (pretty (replicate (posColumn end - posColumn start) '~')) 93 | | otherwise = green (pretty "^…") 94 | 95 | 96 | tabulate2 :: (Pretty a, Pretty b) => Doc -> [(a, b)] -> Doc 97 | tabulate2 _ [] = mempty 98 | tabulate2 s cs = vsep (map (uncurry entry) cs') 99 | where entry a b = fill w (pretty a) <> s <> b 100 | w = maximum (map (columnWidth . fst) cs') 101 | cs' = map (column *** pretty) cs 102 | 103 | newtype Column = Column { unColumn :: (Int, Doc) } 104 | 105 | column :: Pretty a => a -> Column 106 | column a = Column (length (show (plain a')), a') 107 | where a' = pretty a 108 | 109 | columnWidth :: Column -> Int 110 | columnWidth = fst . unColumn 111 | 112 | instance Pretty Column where 113 | pretty = snd . unColumn 114 | 115 | 116 | prettyParens :: Bool -> PP.Doc ann -> PP.Doc ann 117 | prettyParens True = parens 118 | prettyParens False = id 119 | 120 | prettyBraces :: Bool -> PP.Doc ann -> PP.Doc ann 121 | prettyBraces True = braces 122 | prettyBraces False = id 123 | 124 | 125 | red, yellow, green, cyan, blue, magenta :: Doc -> Doc 126 | red = annotate $ color Red 127 | yellow = annotate $ color Yellow 128 | green = annotate $ color Green 129 | cyan = annotate $ color Cyan 130 | blue = annotate $ color Blue 131 | magenta = annotate $ color Magenta 132 | 133 | dullblack :: Doc -> Doc 134 | dullblack = annotate $ colorDull Black 135 | 136 | bold, plain :: Doc -> Doc 137 | bold = annotate ANSI.bold 138 | plain = unAnnotate 139 | 140 | 141 | -- | Debugging helper. 142 | tracePrettyM :: (Applicative m, Pretty a) => a -> m () 143 | tracePrettyM a = unsafePerformIO (pure () <$ prettyPrint a) 144 | 145 | 146 | data Prec = Prec 147 | { precPrecedence :: Maybe Int 148 | , precDoc :: Doc 149 | } 150 | deriving (Show) 151 | 152 | prec :: Int -> Doc -> Prec 153 | prec = Prec . Just 154 | 155 | atom :: Doc -> Prec 156 | atom = Prec Nothing 157 | 158 | withPrec :: Int -> Prec -> Doc 159 | withPrec d (Prec d' a) = prettyParens (maybe False (d >) d') a 160 | -------------------------------------------------------------------------------- /src/Path/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, QuantifiedConstraints, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TupleSections, TypeApplications, TypeOperators #-} 2 | module Path.Core where 3 | 4 | import Control.Applicative (Alternative (..)) 5 | import Control.Carrier.Class 6 | import Control.Monad.Module 7 | import qualified Data.Set as Set 8 | import GHC.Generics (Generic1) 9 | import Path.Pretty 10 | import Path.Scope 11 | import Path.Syntax 12 | import Path.Term 13 | import Prelude hiding (pi) 14 | 15 | data Core f a 16 | = Lam (Scope () f a) 17 | | f a :$ f a 18 | | Let (f a) (Scope () f a) 19 | | Type 20 | | Pi (f a) (Scope () f a) 21 | deriving (Foldable, Functor, Generic1, HFunctor, Traversable) 22 | 23 | deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Core f a) 24 | deriving instance (Ord a, forall a . Eq a => Eq (f a) 25 | , forall a . Ord a => Ord (f a), Monad f) => Ord (Core f a) 26 | deriving instance (Show a, forall a . Show a => Show (f a)) => Show (Core f a) 27 | 28 | instance RightModule Core where 29 | Lam b >>=* f = Lam (b >>=* f) 30 | g :$ a >>=* f = (g >>= f) :$ (a >>= f) 31 | Let v b >>=* f = Let (v >>= f) (b >>=* f) 32 | Type >>=* _ = Type 33 | Pi t b >>=* f = Pi (t >>= f) (b >>=* f) 34 | 35 | 36 | lam :: (Eq a, Carrier sig m, Member Core sig) => a -> m a -> m a 37 | lam n b = send (Lam (bind1 n b)) 38 | 39 | lamFin :: (Carrier sig m, Member Core sig) => m (Var (Fin ('S n)) a) -> m (Var (Fin n) a) 40 | lamFin b = send (Lam (toScopeFin b)) 41 | 42 | lams :: (Eq a, Foldable t, Carrier sig m, Member Core sig) => t a -> m a -> m a 43 | lams names body = foldr lam body names 44 | 45 | unlam :: (Alternative m, Member Core sig, RightModule sig) => a -> Term sig a -> m (a, Term sig a) 46 | unlam n (Term t) | Just (Lam b) <- prj t = pure (n, instantiate1 (pure n) b) 47 | unlam _ _ = empty 48 | 49 | ($$) :: (Carrier sig m, Member Core sig) => m a -> m a -> m a 50 | f $$ a = send (f :$ a) 51 | 52 | 53 | let' :: (Eq a, Carrier sig m, Member Core sig) => a := m a -> m a -> m a 54 | let' (n := v) b = send (Let v (bind1 n b)) 55 | 56 | unlet' :: (Alternative m, Member Core sig, RightModule sig) => a -> Term sig a -> m (a := Term sig a, Term sig a) 57 | unlet' n (Term t) | Just (Let v b) <- prj t = pure (n := v, instantiate1 (pure n) b) 58 | unlet' _ _ = empty 59 | 60 | 61 | type' :: (Carrier sig m, Member Core sig) => m a 62 | type' = send Type 63 | 64 | pi :: (Eq a, Carrier sig m, Member Core sig) => a ::: m a -> m a -> m a 65 | pi (n ::: t) b = send (Pi t (bind1 n b)) 66 | 67 | piFin :: (Carrier sig m, Member Core sig) => m (Var (Fin n) a) -> m (Var (Fin ('S n)) a) -> m (Var (Fin n) a) 68 | piFin t b = send (Pi t (toScopeFin b)) 69 | 70 | -- | Wrap a type in a sequence of pi bindings. 71 | pis :: (Eq a, Foldable t, Carrier sig m, Member Core sig) => t (a ::: m a) -> m a -> m a 72 | pis names body = foldr pi body names 73 | 74 | unpi :: (Alternative m, Member Core sig, RightModule sig) => a -> Term sig a -> m (a ::: Term sig a, Term sig a) 75 | unpi n (Term t) | Just (Pi t b) <- prj t = pure (n ::: t, instantiate1 (pure n) b) 76 | unpi _ _ = empty 77 | 78 | 79 | instance Pretty a => Pretty (Term Core a) where 80 | pretty = prettyTerm prettyCore 81 | 82 | prettyCore 83 | :: (Foldable f, Monad f) 84 | => (forall n . Vec n Doc -> f (Var (Fin n) a) -> Prec) 85 | -> Vec n Doc 86 | -> Core f (Var (Fin n) a) 87 | -> Prec 88 | prettyCore go ctx = \case 89 | Lam b -> 90 | let n = prettyVar (length ctx) 91 | b' = withPrec 0 (go (VS n ctx) (fromScopeFin b)) 92 | in prec 0 (group (vsep [cyan backslash <+> n, cyan dot <+> b'])) 93 | f :$ a -> 94 | let f' = withPrec 10 (go ctx f) 95 | a' = withPrec 11 (go ctx a) 96 | in prec 10 (f' <+> a') 97 | Let v b -> 98 | let v' = withPrec 0 (go ctx v) 99 | n = prettyVar (length ctx) 100 | b' = withPrec 0 (go (VS n ctx) (fromScopeFin b)) 101 | in prec 0 (group (vsep [magenta (pretty "let") <+> pretty (n := v'), magenta dot <+> b'])) 102 | Type -> atom (yellow (pretty "Type")) 103 | Pi t b -> 104 | let t' = withPrec 1 (go ctx t) 105 | n = prettyVar (length ctx) 106 | b' = fromScopeFin b 107 | fvs = foldMap (var Set.singleton (const Set.empty)) b' 108 | b'' = withPrec 0 (go (VS n ctx) b') 109 | t'' | FZ `Set.member` fvs = parens (pretty (n ::: t')) 110 | | otherwise = t' 111 | in prec 0 (group (vsep [t'', arrow <+> b''])) 112 | where arrow = blue (pretty "→") 113 | 114 | 115 | -- $setup 116 | -- >>> import Test.QuickCheck 117 | -------------------------------------------------------------------------------- /src/Path/Module.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, QuantifiedConstraints, StandaloneDeriving, TypeOperators #-} 2 | module Path.Module where 3 | 4 | import Control.Carrier.Class 5 | import Control.Carrier.Cull 6 | import Control.Carrier.Error.Either 7 | import Control.Carrier.NonDet.Church 8 | import Control.Carrier.Reader 9 | import Control.Carrier.State.Strict 10 | import Control.Monad (unless, when) 11 | import Control.Monad.Module 12 | import Data.Foldable (for_, toList) 13 | import Data.List.NonEmpty (NonEmpty(..), (<|), nub) 14 | import qualified Data.Map as Map 15 | import Data.Maybe (fromMaybe) 16 | import Data.Monoid (Alt(..)) 17 | import qualified Data.Set as Set 18 | import Data.Void 19 | import GHC.Generics (Generic1) 20 | import Path.Error 21 | import Path.Name 22 | import Path.Scope 23 | import Path.Span 24 | 25 | data Module f a = Module 26 | { moduleName :: ModuleName 27 | , moduleDocs :: Maybe String 28 | , modulePath :: FilePath 29 | , moduleImports :: Map.Map ModuleName Excerpt 30 | , moduleDecls :: Map.Map User (Decl (Scope User f a)) 31 | } 32 | deriving (Foldable, Functor, Generic1, Traversable) 33 | 34 | deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Module f a) 35 | deriving instance (Ord a, forall a . Eq a => Eq (f a) 36 | , forall a . Ord a => Ord (f a), Monad f) => Ord (Module f a) 37 | deriving instance (Show a, forall a . Show a => Show (f a)) => Show (Module f a) 38 | 39 | instance HFunctor Module 40 | 41 | instance RightModule Module where 42 | Module n d p is ds >>=* f = Module n d p is (fmap (fmap (>>=* f)) ds) 43 | 44 | module' :: Applicative f => ModuleName -> Maybe String -> FilePath -> [Spanned ModuleName] -> [Decl (f User)] -> Module f User 45 | module' n d p is ds = Module n d p (Map.fromList (map unSpan is)) decls 46 | where bind' (Decl u d tm ty) = Decl u d (bind (fmap declName . flip Map.lookup decls) <$> tm) (bind (fmap declName . flip Map.lookup decls) <$> ty) 47 | unSpan (i :~ s) = (i, s) 48 | decls = Map.fromList (map ((,) . declName <*> bind') ds) 49 | 50 | data Decl a = Decl 51 | { declName :: User 52 | , declDocs :: Maybe String 53 | , declTerm :: Spanned a 54 | , declType :: Spanned a 55 | } 56 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 57 | 58 | newtype ModuleGraph f a = ModuleGraph { unModuleGraph :: Map.Map ModuleName (ScopeT Qualified Module f a) } 59 | deriving (Foldable, Functor, Monoid, Semigroup, Traversable) 60 | 61 | deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (ModuleGraph f a) 62 | deriving instance (Ord a, forall a . Eq a => Eq (f a) 63 | , forall a . Ord a => Ord (f a), Monad f) => Ord (ModuleGraph f a) 64 | deriving instance (Show a, forall a . Show a => Show (f a)) => Show (ModuleGraph f a) 65 | 66 | instance HFunctor ModuleGraph where 67 | hmap f (ModuleGraph graph) = ModuleGraph (ScopeT . hmap f . fmap (fmap f) . unScopeT <$> graph) 68 | 69 | instance RightModule ModuleGraph where 70 | ModuleGraph ms >>=* f = ModuleGraph (fmap (>>=* f) ms) 71 | 72 | moduleGraph :: Applicative f => [Module f Qualified] -> ModuleGraph f Void 73 | moduleGraph ms = ModuleGraph (Map.fromList (map ((,) . moduleName <*> bindTEither Left) ms)) 74 | 75 | restrict :: Set.Set ModuleName -> ModuleGraph f a -> ModuleGraph f a 76 | restrict keys = ModuleGraph . flip Map.restrictKeys keys . unModuleGraph 77 | 78 | rename :: (Carrier sig m, Foldable t, Member (Error Notice) sig, Member (Reader Excerpt) sig) 79 | => t (Module f a) 80 | -> User 81 | -> m Qualified 82 | rename ms n = case foldMap (\ m -> [ moduleName m :.: n | d <- toList (moduleDecls m), declName d == n ]) ms of 83 | [x] -> pure x 84 | [] -> freeVariables (pure n) 85 | x:xs -> ambiguousName n (x:|xs) 86 | 87 | runDecl :: Carrier sig m => (a -> ReaderC Excerpt m b) -> Decl a -> m (Decl b) 88 | runDecl f (Decl n d tm ty) = do 89 | tm' <- runSpanned f tm 90 | ty' <- runSpanned f ty 91 | pure (Decl n d tm' ty') 92 | 93 | renameDecl :: (Carrier sig m, Foldable t, Member (Error Notice) sig, Traversable g) 94 | => t (Module f a) 95 | -> Decl (g User) 96 | -> m (Decl (g Qualified)) 97 | renameDecl ms = runDecl (traverse (rename ms)) 98 | 99 | renameModule :: (Carrier sig m, Foldable t, Member (Error Notice) sig, Traversable g) 100 | => t (Module f a) 101 | -> Module g User 102 | -> m (Module g Qualified) 103 | renameModule ms m = do 104 | ds <- traverse (runDecl (traverse (rename ms))) (moduleDecls m) 105 | pure m { moduleDecls = ds } 106 | 107 | renameModuleGraph :: (Applicative f, Carrier sig m, Member (Error Notice) sig, Traversable f) => [Module f User] -> m (ModuleGraph f Void) 108 | renameModuleGraph ms = do 109 | ms' <- traverse (\ m -> renameModule (imported m) m) ms 110 | pure (ModuleGraph (Map.fromList (map ((,) . moduleName <*> bindTEither Left) ms'))) 111 | where imported m = filter (flip Set.member imports . moduleName) ms 112 | where imports = Map.keysSet (moduleImports m) 113 | 114 | modules :: Monad f => ModuleGraph f Void -> [Module f Qualified] 115 | modules (ModuleGraph m) = map (instantiateTEither (either pure absurd)) (Map.elems m) 116 | 117 | lookup :: Monad f => Qualified -> ModuleGraph f Void -> Maybe (Decl (f Qualified)) 118 | lookup (mn :.: n) (ModuleGraph g) = do 119 | sm <- Map.lookup mn g 120 | let m = instantiateTEither (either pure absurd) sm 121 | decl <- Map.lookup n (moduleDecls m) 122 | pure (instantiate (pure . (moduleName m :.:)) <$> decl) 123 | 124 | 125 | lookupModule :: (Carrier sig m, Member (Error Notice) sig) => Spanned ModuleName -> ModuleGraph f a -> m (ScopeT Qualified Module f a) 126 | lookupModule i g = maybe (unknownModule i) pure (Map.lookup (unSpanned i) (unModuleGraph g)) 127 | 128 | cycleFrom :: (Carrier sig m, Effect sig, Member (Error Notice) sig) => ModuleGraph f a -> Spanned ModuleName -> m () 129 | cycleFrom g m = runReader (Set.empty :: Set.Set ModuleName) (runNonDet (runCull (cull (go m)))) >>= cyclicImport . fromMaybe (m :| []) 130 | where go n = do 131 | notVisited <- asks (Set.notMember (unSpanned n)) 132 | if notVisited then do 133 | m <- lookupModule n g 134 | nub . (n <|) <$> local (Set.insert (unSpanned n)) (getAlt (foldMap (Alt . go . uncurry (:~)) (Map.toList (moduleImports (unScopeT m))))) 135 | else 136 | pure (n :| []) 137 | 138 | 139 | loadOrder :: (Carrier sig m, Effect sig, Member (Error Notice) sig) => ModuleGraph f Void -> m [ScopeT Qualified Module f Void] 140 | loadOrder g = reverse <$> execState [] (evalState (Set.empty :: Set.Set ModuleName) (runReader (Set.empty :: Set.Set ModuleName) (for_ (unModuleGraph g) loopM))) 141 | where loopM m = do 142 | visited <- gets (Set.member (moduleName (unScopeT m))) 143 | unless visited . local (Set.insert (moduleName (unScopeT m))) $ do 144 | for_ (Map.toList (moduleImports (unScopeT m))) (uncurry loop) 145 | modify (Set.insert (moduleName (unScopeT m))) 146 | modify (m :) 147 | loop n s = do 148 | inPath <- asks (Set.member n) 149 | when inPath (cycleFrom g (n :~ s)) 150 | visited <- gets (Set.member n) 151 | unless visited . local (Set.insert n) $ do 152 | m <- lookupModule (n :~ s) g 153 | for_ (Map.toList (moduleImports (unScopeT m))) (uncurry loop) 154 | modify (Set.insert n) 155 | modify (m :) 156 | -------------------------------------------------------------------------------- /src/Path/Elab.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, DeriveFunctor, FlexibleContexts, LambdaCase, TypeApplications, TypeOperators #-} 2 | module Path.Elab where 3 | 4 | import Control.Carrier.Class 5 | import Control.Carrier.Error.Either 6 | import Control.Carrier.Reader hiding (Local) 7 | import Control.Carrier.Writer.Strict 8 | import Control.Monad (foldM) 9 | import Data.Bifunctor (Bifunctor (..)) 10 | import Data.Foldable (foldl') 11 | import qualified Data.Map as Map 12 | import Data.Void 13 | import Path.Core 14 | import Path.Error 15 | import Path.Module as Module 16 | import Path.Name 17 | import Path.Plicity (Plicit (..)) 18 | import Path.Problem 19 | import Path.Scope 20 | import Path.Span 21 | import Path.Stack as Stack 22 | import qualified Path.Surface as Surface 23 | import Path.Syntax 24 | import Path.Term 25 | import Prelude hiding (pi) 26 | 27 | assume :: ( Carrier sig m 28 | , Member (Error Notice) sig 29 | , Member (Reader Globals) sig 30 | , Member (Reader Excerpt) sig 31 | ) 32 | => Qualified 33 | -> m (Term (Problem :+: Core) (Var (Fin n) Qualified) ::: Term (Problem :+: Core) (Var (Fin n) Qualified)) 34 | assume v = asks (Stack.find ((== v) . typedTerm)) >>= maybe (freeVariables (pure v)) (pure . (Var (F v) :::) . fmap F . typedType) 35 | 36 | intro :: Monad m 37 | => (Term (Problem :+: Core) (Var (Fin ('S n)) a) -> m (Term (Problem :+: Core) (Var (Fin ('S n)) a) ::: Term (Problem :+: Core) (Var (Fin ('S n)) a))) 38 | -> m (Term (Problem :+: Core) (Var (Fin n) a) ::: Term (Problem :+: Core) (Var (Fin n) a)) 39 | intro body = do 40 | let _A = meta type' 41 | _B = meta type' 42 | u <- goalIs _B (body (first FS <$> _A)) 43 | pure (lamFin u ::: piFin _A _B) 44 | 45 | (-->) :: Monad m 46 | => m (Term (Problem :+: Core) (Var (Fin n) a) ::: Term (Problem :+: Core) (Var (Fin n) a)) 47 | -> (Term (Problem :+: Core) (Var (Fin ('S n)) a) -> m (Term (Problem :+: Core) (Var (Fin ('S n)) a) ::: Term (Problem :+: Core) (Var (Fin ('S n)) a))) 48 | -> m (Term (Problem :+: Core) (Var (Fin n) a) ::: Term (Problem :+: Core) (Var (Fin n) a)) 49 | t --> body = do 50 | t' <- goalIs type' t 51 | b' <- goalIs type' (body (first FS <$> t')) 52 | pure (piFin t' b' ::: type') 53 | 54 | app :: Monad m 55 | => m (Term (Problem :+: Core) (Var (Fin n) a) ::: Term (Problem :+: Core) (Var (Fin n) a)) 56 | -> m (Term (Problem :+: Core) (Var (Fin n) a) ::: Term (Problem :+: Core) (Var (Fin n) a)) 57 | -> m (Term (Problem :+: Core) (Var (Fin n) a) ::: Term (Problem :+: Core) (Var (Fin n) a)) 58 | app f a = do 59 | let _A = meta type' 60 | _B = meta type' 61 | _F = piFin _A _B 62 | f' <- goalIs _F f 63 | a' <- goalIs _A a 64 | pure (f' $$ a' ::: _F $$ a') 65 | 66 | 67 | goalIs :: Monad m 68 | => Term (Problem :+: Core) (Var (Fin n) a) 69 | -> m (Term (Problem :+: Core) (Var (Fin n) a) ::: Term (Problem :+: Core) (Var (Fin n) a)) 70 | -> m (Term (Problem :+: Core) (Var (Fin n) a)) 71 | goalIs ty2 m = do 72 | tm1 ::: ty1 <- m 73 | let tm2 = meta (ty1 === ty2) 74 | pure (tm1 === tm2) 75 | 76 | meta 77 | :: Term (Problem :+: Core) (Var (Fin n) a) 78 | -> Term (Problem :+: Core) (Var (Fin n) a) 79 | meta ty = existsFin ty (pure (B FZ)) 80 | 81 | 82 | elab 83 | :: ( Carrier sig m 84 | , Member (Error Notice) sig 85 | , Member (Reader Globals) sig 86 | , Member (Reader Excerpt) sig 87 | ) 88 | => Vec n (Term (Problem :+: Core) (Var (Fin n) Qualified)) 89 | -> Term Surface.Surface (Var (Fin n) Qualified) 90 | -> m (Term (Problem :+: Core) (Var (Fin n) Qualified) ::: Term (Problem :+: Core) (Var (Fin n) Qualified)) 91 | elab ctx = \case 92 | Var (B n) -> pure (pure (B n) ::: ctx ! n) 93 | Var (F n) -> assume n 94 | Term t -> case t of 95 | Surface.Lam _ b -> intro (\ t -> elab' (VS t (fmap (first FS) <$> ctx)) (fromScopeFin <$> b)) 96 | f Surface.:$ (_ :< a) -> app (elab' ctx f) (elab' ctx a) 97 | Surface.Type -> pure (type' ::: type') 98 | Surface.Pi (_ :< _ ::: t) b -> elab' ctx t --> \ t' -> elab' (VS t' (fmap (first FS) <$> ctx)) (fromScopeFin <$> b) 99 | where elab' ctx m = spanIs (elab ctx <$> m) 100 | 101 | elabDecl :: ( Carrier sig m 102 | , Member (Error Notice) sig 103 | , Member (Reader Globals) sig 104 | , Member (Reader ModuleName) sig 105 | ) 106 | => Decl (Term Surface.Surface Qualified) 107 | -> m (Decl (Term (Problem :+: Core) Qualified)) 108 | elabDecl (Decl name d tm ty) = do 109 | ty' <- runSpanned (fmap strengthen . goalIs type' . elab VZ . fmap F) ty 110 | moduleName <- ask 111 | tm' <- runSpanned (fmap strengthen . local (:> (moduleName :.: name) ::: unSpanned ty') . goalIs (F <$> unSpanned ty') . elab VZ . fmap F) tm 112 | pure (Decl name d tm' ty') 113 | where strengthen :: Term (Problem :+: Core) (Var (Fin 'Z) Qualified) -> Term (Problem :+: Core) Qualified 114 | strengthen = fmap (var absurdFin id) 115 | 116 | elabModule :: ( Carrier sig m 117 | , Member (Error Notice) sig 118 | , Member (Reader (ModuleGraph (Term (Problem :+: Core)) Void)) sig 119 | , Member (Writer (Stack Notice)) sig 120 | ) 121 | => Module (Term Surface.Surface) Qualified 122 | -> m (Module (Term (Problem :+: Core)) Qualified) 123 | elabModule m = runReader (moduleName m) . local @(ModuleGraph (Term (Problem :+: Core)) Void) (Module.restrict (Map.keysSet (moduleImports m))) $ do 124 | -- FIXME: do a topo sort on the decls? or at least make their types known first? or…? 125 | decls <- foldM go mempty (moduleDecls m) 126 | pure m { moduleDecls = decls } 127 | where go decls decl = local (extendGraph decls) . withGlobals $ do 128 | (extendModule decls <$> elabDecl (instantiate (pure . qualified . (moduleDecls m Map.!)) <$> decl)) `catchError` ((decls <$) . logError) 129 | extendModule decls decl = Map.insert (declName decl) (bind (Just . unqualified) <$> decl) decls 130 | extendGraph decls (ModuleGraph g) = ModuleGraph @(Term (Problem :+: Core)) @Void (Map.insert (moduleName m) (bindTEither Left m { moduleDecls = decls }) g) 131 | qualified = (moduleName m :.:) . declName 132 | unqualified (_ :.: u) = u 133 | 134 | withGlobals 135 | :: (Carrier sig m, Member (Reader (ModuleGraph (Term (Problem :+: Core)) Void)) sig) 136 | => ReaderC Globals m a 137 | -> m a 138 | withGlobals m = do 139 | ctx <- asks @(ModuleGraph (Term (Problem :+: Core)) Void) toContext 140 | runReader @Globals ctx m 141 | where toContext g = foldl' definitions Nil (modules g) 142 | definitions ctx m = foldl' define ctx (moduleDecls m) 143 | where define ctx d = ctx :> (moduleName m :.: declName d) ::: inst (declType d) 144 | inst t = instantiateEither (pure . either (moduleName m :.:) id) (unSpanned t) 145 | 146 | logError :: (Member (Writer (Stack Notice)) sig, Carrier sig m) => Notice -> m () 147 | logError = tell . (Nil :>) 148 | 149 | 150 | type Globals = Stack (Qualified ::: Term (Problem :+: Core) Qualified) 151 | 152 | 153 | identity, identityT, constant, constantT, constantTQ :: Term (Problem :+: Core) String 154 | 155 | identity = lam "A" (lam "a" (pure "a")) 156 | identityT = pi ("A" ::: type') (pi ("_" ::: pure "A") (pure "A")) 157 | constant = lam "A" (lam "B" (lam "a" (lam "b" (pure "a")))) 158 | constantT = pi ("A" ::: type') (pi ("B" ::: type') (pi ("_" ::: pure "A") (pi ("_" ::: pure "B") (pure "A")))) 159 | 160 | constantTQ 161 | = exists ("_A" ::: type') (pi ("A" ::: pure "_A") 162 | ( exists ("_B" ::: type') (pi ("B" ::: pure "_B") 163 | ( pi ("_" ::: pure "A") (pi ("_" ::: pure "B") (pure "A")))))) 164 | -------------------------------------------------------------------------------- /src/Path/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveTraversable, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} 2 | module Path.Parser 3 | ( Parser(..) 4 | , parseFile 5 | , parseString 6 | , whole 7 | , keyword 8 | , identifier 9 | , reservedWords 10 | , op 11 | , spanned 12 | ) where 13 | 14 | import Control.Applicative (Alternative(..)) 15 | import Control.Carrier.Class 16 | import Control.Carrier.Reader 17 | import Control.Effect.Choose hiding (optional) 18 | import Control.Effect.Cut 19 | import Control.Effect.Empty 20 | import Control.Effect.Error 21 | import Control.Monad (MonadPlus(..), ap) 22 | import Control.Monad.IO.Class 23 | import qualified Data.HashSet as HashSet 24 | import Data.Maybe (fromMaybe) 25 | import Path.Error (Level(..), Notice(..)) 26 | import Path.Pretty (Doc, pretty) 27 | import Path.Span hiding (spanned) 28 | import Text.Parser.Char 29 | import Text.Parser.Combinators 30 | import Text.Parser.Token 31 | import Text.Parser.Token.Highlight 32 | 33 | whole :: TokenParsing m => m a -> m a 34 | whole p = whiteSpace *> p <* eof 35 | 36 | 37 | identifier :: (Monad m, TokenParsing m) => m String 38 | identifier = ident (IdentifierStyle "identifier" letter (alphaNum <|> char '\'') reservedWords Identifier ReservedIdentifier) 39 | 40 | 41 | reservedWords :: HashSet.HashSet String 42 | reservedWords = HashSet.fromList [ "Type", "module", "import" ] 43 | 44 | keyword, op :: TokenParsing m => String -> m String 45 | 46 | keyword s = token (highlight ReservedIdentifier (try (string s <* notFollowedBy alphaNum))) s 47 | 48 | op s = token (highlight Operator (string s)) s 49 | 50 | 51 | data Parser m k 52 | = forall a . Accept (Char -> Maybe a) (a -> m k) 53 | | forall a . Label (m a) String (a -> m k) 54 | | Unexpected String 55 | | Position (Pos -> m k) 56 | 57 | deriving instance Functor m => Functor (Parser m) 58 | 59 | instance HFunctor Parser where 60 | hmap f (Accept p k) = Accept p (f . k) 61 | hmap f (Label m s k) = Label (f m) s (f . k) 62 | hmap _ (Unexpected s) = Unexpected s 63 | hmap f (Position k) = Position (f . k) 64 | 65 | instance Effect Parser where 66 | handle state handler (Accept p k) = Accept p (handler . (<$ state) . k) 67 | handle state handler (Label m s k) = Label (handler (m <$ state)) s (handler . fmap k) 68 | handle _ _ (Unexpected s) = Unexpected s 69 | handle state handler (Position k) = Position (handler . (<$ state) . k) 70 | 71 | 72 | accept :: (Carrier sig m, Member Parser sig) => (Char -> Maybe a) -> m a 73 | accept p = send (Accept p pure) 74 | 75 | path :: (Carrier sig m, Member (Reader FilePath) sig) => m FilePath 76 | path = ask 77 | 78 | line :: (Carrier sig m, Member Parser sig, Member (Reader [String]) sig) => m String 79 | line = do 80 | pos <- position 81 | asks (!! posLine pos) 82 | 83 | position :: (Carrier sig m, Member Parser sig) => m Pos 84 | position = send (Position pure) 85 | 86 | spanned :: (Carrier sig m, Member (Reader [String]) sig, Member (Reader FilePath) sig, Member Parser sig) => m a -> m (Spanned a) 87 | spanned m = do 88 | path <- path 89 | line <- line 90 | start <- position 91 | a <- m 92 | end <- position 93 | pure (a :~ Excerpt path line (Span start end)) 94 | 95 | 96 | runParser :: Applicative m => FilePath -> Pos -> String -> ParserC (ReaderC FilePath (ReaderC [String] m)) a -> m (Either Notice a) 97 | runParser path pos input m = runReader inputLines (runReader path (runParserC m success failure failure pos input)) 98 | where success _ _ a = pure (Right a) 99 | failure pos reason = pure (Left (Notice (Just Error) (Excerpt path (inputLines !! posLine pos) (Span pos pos)) (fromMaybe (pretty "unknown error") reason) [])) 100 | inputLines = lines input 101 | lines "" = [""] 102 | lines s = let (line, rest) = takeLine s in line : lines rest 103 | takeLine "" = ("", "") 104 | takeLine ('\n':rest) = ("\n", rest) 105 | takeLine (c :rest) = let (cs, rest') = takeLine rest in (c:cs, rest') 106 | 107 | parseString :: (Carrier sig m, Member (Error Notice) sig) => ParserC (ReaderC FilePath (ReaderC [String] m)) a -> Pos -> String -> m a 108 | parseString p pos input = runParser "(interactive)" pos input p >>= either throwError pure 109 | 110 | parseFile :: (Carrier sig m, Member (Error Notice) sig, MonadIO m) => ParserC (ReaderC FilePath (ReaderC [String] m)) a -> FilePath -> m a 111 | parseFile p path = do 112 | input <- liftIO (readFile path) 113 | runParser path (Pos 0 0) input p >>= either throwError pure 114 | 115 | newtype ParserC m a = ParserC 116 | { runParserC 117 | :: forall r 118 | . (Pos -> String -> a -> m r) -- success 119 | -> (Pos -> Maybe Doc -> m r) -- empty 120 | -> (Pos -> Maybe Doc -> m r) -- cut 121 | -> Pos 122 | -> String 123 | -> m r 124 | } 125 | deriving (Functor) 126 | 127 | instance Applicative (ParserC m) where 128 | pure a = ParserC (\ just _ _ pos input -> just pos input a) 129 | (<*>) = ap 130 | 131 | instance Alternative (ParserC m) where 132 | empty = ParserC (\ _ nothing _ pos _ -> nothing pos Nothing) 133 | 134 | ParserC l <|> ParserC r = ParserC (\ just nothing fail pos input -> l just (const (const (r just nothing fail pos input))) fail pos input) 135 | 136 | instance Monad (ParserC m) where 137 | m >>= f = ParserC (\ just nothing fail -> runParserC m (\ pos input a -> runParserC (f a) just nothing fail pos input) nothing fail) 138 | 139 | instance MonadPlus (ParserC m) 140 | 141 | instance (Carrier sig m, Effect sig) => Parsing (ParserC m) where 142 | try = call 143 | eof = notFollowedBy anyChar "end of input" 144 | unexpected s = send (Unexpected s) 145 | m s = send (Label m s pure) 146 | notFollowedBy p = try (optional p >>= maybe (pure ()) (unexpected . show)) 147 | 148 | instance (Carrier sig m, Effect sig) => CharParsing (ParserC m) where 149 | satisfy p = accept (\ c -> if p c then Just c else Nothing) 150 | 151 | instance (Carrier sig m, Effect sig) => TokenParsing (ParserC m) 152 | 153 | instance (Carrier sig m, Effect sig) => Carrier (Parser :+: Cut :+: Empty :+: Choose :+: sig) (ParserC m) where 154 | eff = \case 155 | L parser -> case parser of 156 | Accept p k -> ParserC (\ just nothing _ pos input -> case input of 157 | c:cs | Just a <- p c -> just (advancePos c pos) cs a 158 | | otherwise -> nothing pos (Just (pretty "unexpected " <> pretty c)) 159 | _ -> nothing pos (Just (pretty "unexpected EOF"))) >>= k 160 | Label m s k -> ParserC (\ just nothing fail -> runParserC m just (\ p r -> nothing p (r <|> Just (pretty s))) (\ p r -> fail p (r <|> Just (pretty s)))) >>= k 161 | Unexpected s -> ParserC $ \ _ nothing _ pos _ -> nothing pos (Just (pretty s)) 162 | Position k -> ParserC (\ just _ _ pos input -> just pos input pos) >>= k 163 | R (L cut) -> case cut of 164 | Cutfail -> ParserC $ \ _ _ fail pos _ -> fail pos Nothing 165 | Call m k -> ParserC (\ just nothing _ -> runParserC m just nothing nothing) >>= k 166 | R (R (L Empty)) -> empty 167 | R (R (R (L (Choose k)))) -> k True <|> k False 168 | R (R (R (R other))) -> ParserC $ \ just nothing _ pos input -> eff (handle (success pos input ()) (result runParser failure) other) >>= result just nothing 169 | where runParser p s m = runParserC m (\ p s -> pure . success p s) failure failure p s 170 | success pos input a = Result pos (Right (input, a)) 171 | failure pos reason = pure (Result pos (Left reason)) 172 | 173 | 174 | data Result a = Result 175 | { resultPos :: {-# UNPACK #-} !Pos 176 | , resultState :: Either (Maybe Doc) (String, a) 177 | } 178 | deriving (Foldable, Functor, Show, Traversable) 179 | 180 | result :: (Pos -> String -> a -> b) -> (Pos -> Maybe Doc -> b) -> Result a -> b 181 | result success failure (Result pos state) = either (failure pos) (uncurry (success pos)) state 182 | -------------------------------------------------------------------------------- /src/Path/Scope.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, DeriveGeneric, DeriveTraversable, EmptyCase, FlexibleInstances, GADTs, LambdaCase, MultiParamTypeClasses, QuantifiedConstraints, RankNTypes, StandaloneDeriving #-} 2 | module Path.Scope where 3 | 4 | import Control.Applicative (liftA2) 5 | import Control.Carrier.Class 6 | import Control.Monad ((>=>), guard) 7 | import Control.Monad.Module 8 | import Control.Monad.Trans (MonadTrans (..)) 9 | import Data.Bifoldable 10 | import Data.Bifunctor 11 | import Data.Bitraversable 12 | import Data.Function (on) 13 | import Data.List (elemIndex) 14 | import GHC.Generics (Generic1) 15 | import Path.Pretty 16 | 17 | data Var a b = B a | F b 18 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 19 | 20 | instance (Pretty b, Pretty f) => Pretty (Var b f) where 21 | pretty = \case 22 | B b -> pretty b 23 | F f -> pretty f 24 | 25 | instance Bifoldable Var where 26 | bifoldMap f g = \case 27 | B a -> f a 28 | F a -> g a 29 | 30 | instance Bitraversable Var where 31 | bitraverse f g = \case 32 | B a -> B <$> f a 33 | F a -> F <$> g a 34 | 35 | instance Bifunctor Var where 36 | bimap f g = \case 37 | B a -> B (f a) 38 | F a -> F (g a) 39 | 40 | instance Applicative (Var a) where 41 | pure = F 42 | B e <*> _ = B e 43 | F f <*> a = f <$> a 44 | 45 | instance Monad (Var a) where 46 | B e >>= _ = B e 47 | F a >>= f = f a 48 | 49 | var :: (a -> c) -> (b -> c) -> Var a b -> c 50 | var z s = \case { B a -> z a ; F b -> s b } 51 | 52 | match :: Applicative f => (b -> Either a c) -> b -> Var a (f c) 53 | match f x = either B (F . pure) (f x) 54 | 55 | matchM :: (Applicative f, Functor m) => (b -> m (Either a c)) -> b -> m (Var a (f c)) 56 | matchM f x = either B (F . pure) <$> f x 57 | 58 | matchMaybe :: (b -> Maybe a) -> (b -> Either a b) 59 | matchMaybe f a = maybe (Right a) Left (f a) 60 | 61 | 62 | data Nat = Z | S Nat 63 | deriving (Eq, Ord, Show) 64 | 65 | data Fin n where 66 | FZ :: Fin ('S n) 67 | FS :: Fin n -> Fin ('S n) 68 | 69 | deriving instance Eq (Fin n) 70 | deriving instance Ord (Fin n) 71 | deriving instance Show (Fin n) 72 | 73 | instance Pretty (Fin n) where 74 | pretty = prettyVar . finToInt 75 | 76 | absurdFin :: Fin 'Z -> a 77 | absurdFin v = case v of {} 78 | 79 | finToInt :: Fin n -> Int 80 | finToInt FZ = 0 81 | finToInt (FS n) = 1 + finToInt n 82 | 83 | strengthenFin :: Fin ('S n) -> Maybe (Fin n) 84 | strengthenFin FZ = Nothing 85 | strengthenFin (FS n) = Just n 86 | 87 | 88 | data Vec n a where 89 | VZ :: Vec 'Z a 90 | VS :: a -> Vec n a -> Vec ('S n) a 91 | 92 | deriving instance Eq a => Eq (Vec n a) 93 | deriving instance Ord a => Ord (Vec n a) 94 | deriving instance Show a => Show (Vec n a) 95 | 96 | deriving instance Foldable (Vec n) 97 | deriving instance Functor (Vec n) 98 | deriving instance Traversable (Vec n) 99 | 100 | (!) :: Vec n a -> Fin n -> a 101 | VS h _ ! FZ = h 102 | VS _ t ! FS n = t ! n 103 | VZ ! n = absurdFin n 104 | 105 | infixl 9 ! 106 | 107 | 108 | newtype Scope a f b = Scope (f (Var a (f b))) 109 | deriving (Foldable, Functor, Generic1, Traversable) 110 | 111 | unScope :: Scope a f b -> f (Var a (f b)) 112 | unScope (Scope s) = s 113 | 114 | instance (Monad f, Eq a, Eq b, forall a . Eq a => Eq (f a)) => Eq (Scope a f b) where 115 | (==) = (==) `on` fromScope 116 | 117 | instance (Monad f, Ord a, Ord b, forall a . Eq a => Eq (f a) 118 | , forall a . Ord a => Ord (f a)) => Ord (Scope a f b) where 119 | compare = compare `on` fromScope 120 | 121 | deriving instance (Show a, Show b, forall a . Show a => Show (f a)) => Show (Scope a f b) 122 | 123 | instance Applicative f => Applicative (Scope a f) where 124 | pure = Scope . pure . F . pure 125 | Scope f <*> Scope a = Scope (liftA2 (liftA2 (<*>)) f a) 126 | 127 | instance Monad f => Monad (Scope a f) where 128 | Scope e >>= f = Scope (e >>= var (pure . B) (>>= unScope . f)) 129 | 130 | instance RightModule (Scope a) where 131 | Scope m >>=* f = Scope (fmap (>>= f) <$> m) 132 | 133 | instance MonadTrans (Scope a) where 134 | lift = Scope . pure . F 135 | 136 | instance HFunctor (Scope a) where 137 | hmap f = Scope . f . fmap (fmap f) . unScope 138 | 139 | 140 | -- | Bind occurrences of a variable in a term, producing a term in which the variable is bound. 141 | bind1 :: (Applicative f, Eq a) => a -> f a -> Scope () f a 142 | bind1 n = bind (guard . (== n)) 143 | 144 | bind :: Applicative f => (b -> Maybe a) -> f b -> Scope a f b 145 | bind f = bindEither (matchMaybe f) 146 | 147 | bindEither :: Applicative f => (b -> Either a c) -> f b -> Scope a f c 148 | bindEither f = Scope . fmap (match f) -- FIXME: succ as little of the expression as possible, cf https://twitter.com/ollfredo/status/1145776391826358273 149 | 150 | bindSimultaneous :: (Applicative f, Eq a) => [(a, f a)] -> [Scope Int f a] 151 | bindSimultaneous bs = map (bind (`elemIndex` map fst bs) . snd) bs 152 | 153 | -- | Substitute a term for the free variable in a given term, producing a closed term. 154 | instantiate1 :: Monad f => f b -> Scope a f b -> f b 155 | instantiate1 t = instantiate (const t) 156 | 157 | instantiate :: Monad f => (a -> f b) -> Scope a f b -> f b 158 | instantiate f = instantiateEither (either f pure) 159 | 160 | instantiateEither :: Monad f => (Either a b -> f c) -> Scope a f b -> f c 161 | instantiateEither f = unScope >=> var (f . Left) (>>= f . Right) 162 | 163 | fromScope :: Monad f => Scope a f b -> f (Var a b) 164 | fromScope = unScope >=> sequenceA 165 | 166 | fromScopeFin :: Monad f => Scope () f (Var (Fin n) b) -> f (Var (Fin ('S n)) b) 167 | fromScopeFin = unScope >=> var (const (pure (B FZ))) (fmap (first FS)) 168 | 169 | toScope :: Applicative f => f (Var a b) -> Scope a f b 170 | toScope = Scope . fmap (fmap pure) 171 | 172 | toScopeFin :: Applicative f => f (Var (Fin ('S n)) b) -> Scope () f (Var (Fin n) b) 173 | toScopeFin = Scope . fmap (match (var (maybe (Left ()) (Right . B) . strengthenFin) (Right . F))) 174 | 175 | 176 | -- | Like 'Scope', but allows the inner functor to vary. Useful for syntax like declaration scopes, case alternatives, etc., which can bind variables, but cannot (directly) consist solely of them. 177 | newtype ScopeT a t f b = ScopeT (t f (Var a (f b))) 178 | deriving (Foldable, Functor, Generic1, Traversable) 179 | 180 | unScopeT :: ScopeT a t f b -> t f (Var a (f b)) 181 | unScopeT (ScopeT s) = s 182 | 183 | instance (RightModule t, Monad f, Eq a, Eq b, forall a . Eq a => Eq (t f a)) => Eq (ScopeT a t f b) where 184 | (==) = (==) `on` fromScopeT 185 | 186 | instance (RightModule t, Monad f, Ord a, Ord b, forall a . Eq a => Eq (t f a) 187 | , forall a . Ord a => Ord (t f a)) => Ord (ScopeT a t f b) where 188 | compare = compare `on` fromScopeT 189 | 190 | deriving instance (Show a, Show b, forall a . Show a => Show (t f a) 191 | , forall a . Show a => Show (f a)) => Show (ScopeT a t f b) 192 | 193 | instance (Applicative (t f), Applicative f) => Applicative (ScopeT a t f) where 194 | pure = ScopeT . pure . F . pure 195 | ScopeT f <*> ScopeT a = ScopeT (liftA2 (liftA2 (<*>)) f a) 196 | 197 | instance (Monad (t f), MonadTrans t, Monad f) => Monad (ScopeT a t f) where 198 | ScopeT e >>= f = ScopeT (e >>= var (pure . B) ((>>= unScopeT . f) . lift)) 199 | 200 | instance (HFunctor t, forall g . Functor g => Functor (t g)) => RightModule (ScopeT b t) where 201 | ScopeT s >>=* k = ScopeT (fmap (>>= k) <$> s) 202 | 203 | instance MonadTrans f => MonadTrans (ScopeT a f) where 204 | lift = ScopeT . lift . pure . F 205 | 206 | instance (HFunctor t, forall g . Functor g => Functor (t g)) => HFunctor (ScopeT a t) where 207 | hmap f = ScopeT . hmap f . fmap (fmap f) . unScopeT 208 | 209 | 210 | -- | Bind occurrences of a variable in a term, producing a term in which the variable is bound. 211 | bind1T :: (Functor (t f), Applicative f, Eq a) => a -> t f a -> ScopeT () t f a 212 | bind1T n = bindT (guard . (== n)) 213 | 214 | bindT :: (Functor (t f), Applicative f) => (b -> Maybe a) -> t f b -> ScopeT a t f b 215 | bindT f = bindTEither (matchMaybe f) 216 | 217 | bindTEither :: (Functor (t f), Applicative f) => (b -> Either a c) -> t f b -> ScopeT a t f c 218 | bindTEither f = ScopeT . fmap (match f) -- FIXME: succ as little of the expression as possible, cf https://twitter.com/ollfredo/status/1145776391826358273 219 | 220 | -- | Substitute a term for the free variable in a given term, producing a closed term. 221 | instantiate1T :: (RightModule t, Monad f) => f b -> ScopeT a t f b -> t f b 222 | instantiate1T t = instantiateT (const t) 223 | 224 | instantiateT :: (RightModule t, Monad f) => (a -> f b) -> ScopeT a t f b -> t f b 225 | instantiateT f = instantiateTEither (either f pure) 226 | 227 | instantiateTEither :: (RightModule t, Monad f) => (Either a b -> f c) -> ScopeT a t f b -> t f c 228 | instantiateTEither f = unScopeT >=>* var (f . Left) (>>= f . Right) 229 | 230 | fromScopeT :: (RightModule t, Monad f) => ScopeT a t f b -> t f (Var a b) 231 | fromScopeT = unScopeT >=>* sequenceA 232 | 233 | toScopeT :: (Functor (t f), Applicative f) => t f (Var a b) -> ScopeT a t f b 234 | toScopeT = ScopeT . fmap (fmap pure) 235 | -------------------------------------------------------------------------------- /src/Path/REPL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass, DeriveFunctor, DeriveGeneric, DerivingStrategies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, MultiParamTypeClasses, RankNTypes, TypeApplications, TypeOperators, UndecidableInstances #-} 2 | module Path.REPL where 3 | 4 | import Control.Carrier.Class 5 | import Control.Carrier.Error.Either 6 | import Control.Carrier.Lift 7 | import Control.Carrier.Reader 8 | import Control.Carrier.State.Strict 9 | import Control.Carrier.Writer.Strict 10 | import Control.Monad (foldM, join, unless, void) 11 | import Control.Monad.Fix 12 | import Control.Monad.IO.Class 13 | import Control.Monad.Trans (MonadTrans(..)) 14 | import Data.Foldable (for_) 15 | import qualified Data.Map as Map 16 | import qualified Data.Set as Set 17 | import Data.Traversable (for) 18 | import Data.Void 19 | import GHC.Generics (Generic1) 20 | import Path.Core 21 | import Path.Elab 22 | import Path.Error 23 | import Path.Module as Module 24 | import Path.Name 25 | import Path.Package 26 | import Path.Parser (parseString, whole) 27 | import Path.Parser.Module (parseModule) 28 | import Path.Parser.REPL (command) 29 | import Path.Pretty 30 | import Path.Problem 31 | import Path.REPL.Command as Command 32 | import Path.Scope 33 | import Path.Span 34 | import Path.Stack 35 | import qualified Path.Surface as Surface 36 | import Path.Term 37 | import Prelude hiding (print) 38 | import System.Console.Haskeline hiding (Handler, handle) 39 | import System.Directory (createDirectoryIfMissing, getHomeDirectory) 40 | 41 | data REPL m k 42 | = Prompt String (Maybe String -> m k) 43 | | Print Doc (m k) 44 | | AskLine (Line -> m k) 45 | deriving stock (Functor, Generic1) 46 | deriving anyclass (Effect, HFunctor) 47 | 48 | 49 | prompt :: (Carrier sig m, Member REPL sig) => String -> m (Maybe String) 50 | prompt p = send (Prompt p pure) 51 | 52 | print :: (Carrier sig m, Member REPL sig) => Doc -> m () 53 | print s = send (Print s (pure ())) 54 | 55 | askLine :: (Carrier sig m, Member REPL sig) => m Line 56 | askLine = send (AskLine pure) 57 | 58 | 59 | runREPL :: MonadException m => Prefs -> Settings m -> REPLC m a -> m a 60 | runREPL prefs settings = runInputTWithPrefs prefs settings . runM . runReader (Line 0) . runREPLC 61 | 62 | newtype REPLC m a = REPLC { runREPLC :: ReaderC Line (LiftC (InputT m)) a } 63 | deriving newtype (Applicative, Functor, Monad, MonadFix, MonadIO) 64 | 65 | instance (MonadException m, MonadIO m) => Carrier (REPL :+: Lift (InputT m)) (REPLC m) where 66 | eff (L (Prompt prompt k)) = REPLC $ do 67 | str <- lift (lift (getInputLine (cyan <> prompt <> plain))) 68 | local increment (runREPLC (k str)) 69 | where cyan = "\ESC[1;36m\STX" 70 | plain = "\ESC[0m\STX" 71 | eff (L (Print text k)) = putDoc text *> k 72 | eff (L (AskLine k)) = REPLC ask >>= k 73 | eff (R other) = REPLC (eff (R (handleCoercible other))) 74 | 75 | runControlIO :: (forall x . m x -> IO x) -> ControlIOC m a -> m a 76 | runControlIO handler = runReader (Handler handler) . runControlIOC 77 | 78 | newtype ControlIOC m a = ControlIOC { runControlIOC :: ReaderC (Handler m) m a } 79 | deriving newtype (Applicative, Functor, Monad, MonadFix, MonadIO) 80 | 81 | newtype Handler m = Handler (forall x . m x -> IO x) 82 | 83 | runHandler :: Handler m -> ControlIOC m a -> IO a 84 | runHandler h@(Handler handler) = handler . runReader h . runControlIOC 85 | 86 | instance Carrier sig m => Carrier sig (ControlIOC m) where 87 | eff op = ControlIOC (eff (R (handleCoercible op))) 88 | 89 | instance (Carrier sig m, MonadIO m) => MonadException (ControlIOC m) where 90 | controlIO f = ControlIOC $ do 91 | handler <- ask 92 | liftIO (f (RunIO (fmap pure . runHandler handler)) >>= runHandler handler) 93 | 94 | repl :: MonadIO m => [FilePath] -> m () 95 | repl packageSources = liftIO $ do 96 | homeDir <- getHomeDirectory 97 | prefs <- readPrefs (homeDir <> "/.haskeline") 98 | let settingsDir = homeDir <> "/.local/path" 99 | settings = Settings 100 | { complete = noCompletion 101 | , historyFile = Just (settingsDir <> "/repl_history") 102 | , autoAddHistory = True 103 | } 104 | createDirectoryIfMissing True settingsDir 105 | runM (runControlIO runM 106 | (runREPL prefs settings 107 | (script packageSources))) 108 | 109 | newtype Line = Line Int 110 | 111 | increment :: Line -> Line 112 | increment (Line n) = Line (n + 1) 113 | 114 | linePos :: Line -> Pos 115 | linePos (Line l) = Pos l 0 116 | 117 | script :: ( Carrier sig m 118 | , Effect sig 119 | , Member REPL sig 120 | , MonadIO m 121 | ) 122 | => [FilePath] 123 | -> m () 124 | script packageSources 125 | = evalState (ModuleGraph mempty :: ModuleGraph (Term (Problem :+: Core)) Void) 126 | . evalState (mempty @(Set.Set ModuleName)) 127 | . runReader (ModuleName "(interpreter)") 128 | . fmap (either id id) 129 | . runError @() 130 | $ runError loop >>= either (print . pretty @Notice) pure 131 | where loop = (prompt "λ: " >>= parseCommand >>= maybe (pure ()) runCommand . join) `catchError` (print . pretty @Notice) >> loop 132 | parseCommand str = do 133 | l <- askLine 134 | traverse (parseString (whole command) (linePos l)) str 135 | runCommand = \case 136 | Quit -> throwError () 137 | Help -> print helpDoc 138 | TypeOf tm -> elaborate tm >>= print . pretty . unSpanned 139 | Command.Decl decl -> void $ runSubgraph (asks @(ModuleGraph (Term (Problem :+: Core)) Void) (fmap unScopeT . unModuleGraph) >>= flip renameDecl decl >>= withGlobals . elabDecl) 140 | Eval tm -> elaborate tm >>= gets . flip whnf . unSpanned >>= print . pretty 141 | ShowModules -> do 142 | ms <- gets @(ModuleGraph (Term (Problem :+: Core)) Void) (Map.toList . unModuleGraph) 143 | unless (Prelude.null ms) $ print (tabulate2 space (map (fmap (parens . pretty . modulePath . unScopeT)) ms)) 144 | Reload -> reload 145 | Command.Import i -> modify (Set.insert (unSpanned i)) 146 | Command.Doc moduleName -> do 147 | m <- get >>= lookupModule moduleName 148 | case moduleDocs (unScopeT (m :: ScopeT Qualified Module (Term (Problem :+: Core)) Void)) of 149 | Just d -> print (pretty d) 150 | Nothing -> print (pretty "no docs for" <+> squotes (pretty (unSpanned moduleName))) 151 | reload = do 152 | sorted <- traverse parseModule packageSources >>= renameModuleGraph >>= fmap (map (instantiateTEither (either pure absurd))) . loadOrder 153 | checked <- foldM (load (length packageSources)) (mempty @(ModuleGraph (Term (Problem :+: Core)) Void)) (zip [(1 :: Int)..] sorted) 154 | put checked 155 | load n graph (i, m) = skipDeps graph m $ do 156 | let name = moduleName m 157 | ordinal = brackets (pretty i <+> pretty "of" <+> pretty n) 158 | path = parens (pretty (modulePath m)) 159 | print (ordinal <+> pretty "Compiling" <+> pretty name <+> path) 160 | (errs, res) <- runWriter (runReader graph (elabModule m)) 161 | if Prelude.null errs then 162 | pure (ModuleGraph (Map.insert name (bindTEither Left res) (unModuleGraph graph))) 163 | else do 164 | for_ @Stack errs (print . pretty @Notice) 165 | pure graph 166 | skipDeps graph m action = if all @Set.Set (flip Set.member (Map.keysSet (unModuleGraph graph))) (Map.keysSet (moduleImports m)) then action else pure graph 167 | 168 | elaborate :: ( Carrier sig m 169 | , Member (Error Notice) sig 170 | , Member (State (ModuleGraph (Term (Problem :+: Core)) Void)) sig 171 | , Member (State (Set.Set ModuleName)) sig 172 | ) 173 | => Spanned (Term Surface.Surface User) 174 | -> m (Spanned (Term (Problem :+: Core) Qualified)) 175 | elaborate = runSpanned $ \ tm -> fmap (var absurdFin id) <$> do 176 | let ty = meta type' 177 | runSubgraph (asks @(ModuleGraph (Term (Problem :+: Core)) Void) (fmap unScopeT . unModuleGraph) >>= for tm . rename >>= withGlobals . goalIs ty . elab VZ . fmap F) 178 | 179 | -- | Evaluate a term to weak head normal form. 180 | -- 181 | -- This involves looking up variables at the head of neutral terms in the environment, but will leave other values alone, as they’re already constructor-headed. 182 | whnf :: ModuleGraph (Term (Problem :+: Core)) Void -> Term (Problem :+: Core) Qualified -> Term (Problem :+: Core) Qualified 183 | whnf graph = go where 184 | go (Term (R (Var n :$ a))) = maybe (Var n $$ a) (go . ($$ a) . unSpanned . declTerm) (Module.lookup n graph) 185 | go v = v 186 | 187 | runSubgraph :: (Carrier sig m, Member (State (ModuleGraph (Term (Problem :+: Core)) Void)) sig, Member (State (Set.Set ModuleName)) sig) => ReaderC (ModuleGraph (Term (Problem :+: Core)) Void) m a -> m a 188 | runSubgraph m = do 189 | imported <- get 190 | subgraph <- gets @(ModuleGraph (Term (Problem :+: Core)) Void) (Module.restrict imported) 191 | runReader subgraph m 192 | 193 | basePackage :: Package 194 | basePackage = Package 195 | { packageName = "Base" 196 | , packageSources = 197 | [ "src/Base/Bool.path" 198 | , "src/Base/Either.path" 199 | , "src/Base/Fin.path" 200 | , "src/Base/Fix.path" 201 | , "src/Base/Function.path" 202 | , "src/Base/Lazy.path" 203 | , "src/Base/List.path" 204 | , "src/Base/Maybe.path" 205 | , "src/Base/Nat.path" 206 | , "src/Base/Pair.path" 207 | , "src/Base/Sigma.path" 208 | , "src/Base/Unit.path" 209 | , "src/Base/Vector.path" 210 | , "src/Base/Void.path" 211 | ] 212 | , packageConstraints = [] 213 | } 214 | 215 | helpDoc :: Doc 216 | helpDoc = tabulate2 (space <+> space) entries 217 | where entries = 218 | [ (":help, :?", w "display this list of commands") 219 | , (":quit, :q", w "exit the repl") 220 | , (":reload, :r", w "reload the current package") 221 | , (":type, :t ", w "show the type of ") 222 | ] 223 | w = align . fillSep . map pretty . words 224 | --------------------------------------------------------------------------------