├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── examples ├── codeOfGenLangs │ └── depTypedLC.lc ├── langSpecs │ ├── convoluted.fpl │ └── depTypedLC.fpl └── tests │ ├── fail │ ├── almost.fpl │ ├── example.fpl │ ├── example2.fpl │ └── tst1.fpl │ └── pass │ └── tst1.fpl ├── fpl-exploration-tool.cabal ├── rules.pdf ├── src ├── langGenerator │ ├── CodeGen.hs │ ├── CodeGen │ │ ├── ADT.hs │ │ ├── Common.hs │ │ ├── ConsCtx.hs │ │ ├── Infer.hs │ │ ├── MonadInstance.hs │ │ ├── Nf.hs │ │ └── RightSide │ │ │ ├── Common.hs │ │ │ ├── Exprs.hs │ │ │ ├── Helpers.hs │ │ │ ├── Infer.hs │ │ │ ├── Nf.hs │ │ │ └── Solver.hs │ ├── Default │ │ ├── .gitignore │ │ ├── Grammar.y │ │ ├── PStruct.hs │ │ └── Tokens.x │ ├── GeneratorTemplates │ │ └── LangTemplate.hs │ ├── Lang.hs │ ├── SimpleBound.hs │ └── generated │ │ ├── DepTypedLC.hs │ │ └── Pars.hs └── specLang │ ├── AST.hs │ ├── AST │ ├── Axiom.hs │ ├── Judgement.hs │ ├── Reduction.hs │ └── Term.hs │ ├── SortCheck.hs │ ├── SortCheck │ ├── AxCtxVars.hs │ ├── Axiom.hs │ ├── Forall.hs │ ├── FunSym.hs │ ├── Judgement.hs │ ├── Reduction.hs │ ├── Sort.hs │ ├── SymbolTable.hs │ └── Term.hs │ └── parsLex │ ├── .gitignore │ ├── Lexer.x │ └── Parser.y ├── stack.yaml └── test ├── Spec.hs └── specLang └── TestSortCheck.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .*/* 2 | asd.hs 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # This is pretty much a work-in-progress. 2 | 3 | The project is aimed at defining dependently typed languages via specifying their inference and reduction rules. 4 | 5 | The program then generates our target language's parser and typechecker, so we can play around with the language. 6 | 7 | Think of it as a high level yacc+lex. 8 | 9 | # To launch: 10 | 11 | - stack install alex happy 12 | - stack exec alex src/specLang/parsLex/Lexer.x 13 | - stack exec happy alex src/specLang/parsLex/Parser.y 14 | - stack install 15 | 16 | ~/.local/bin/fpl-exploration-tool-exe "examples/langSpecs/depTypedLC.fpl" > my_src.hs 17 | 18 | There are 2 modules: SortCheck and CodeGen, and two functions codeGenIO and sortCheckIO you can use those if you prefer. 19 | 20 | # Notes about spec language: 21 | - May have depsorts and simplesorts or only depsorts 22 | - May have reductions or/and axioms 23 | - axiom names are alphaNum starting with a numeric, may contain "_", "-", "'" 24 | - subst binds closer than binders (x y.T[z:=ttt] == x y.(T[z:=ttt])) 25 | 26 | # Restrictions imposed: 27 | - conclusion of an axiom/reduction may not have a ctx (axioms always look like this .... |--- |- funSym()) 28 | 29 | - only funsyms are allowed in axiom conclusions (no equations) 30 | - only metavars are allowed in funsyms in conclusions 31 | - if an axiom conclusion is a term it must have a type (can't just say |--- |- false def, must say |--- |- false : bool) 32 | - no substitutions are allowed for the left hand of a reduction 33 | - may subst only into metavars 34 | 35 | - if variables of metavariables (X) have type of metavars, they may use only metavars that come before X in funsym in conclusion (Eg: |--- |- f(A, x.B, z.Y, r.T) -- here z may use only A and B as its' type, x may use only A, while r may use A, B, and Y) 36 | - so if we have f(..., xy.T) we demand a premise looking like this ctx |- T ! 37 | 38 | - only parts of reductions used are these a => b (context, types or premises are not taken into account yet) 39 | - in reductions a => b all(!) metavars of b must be present in a 40 | 41 | - c-stability - reductions are always stable. Others are concatenated with the types on top 42 | 43 | --- 44 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Environment 4 | 5 | import CodeGen 6 | 7 | main :: IO () 8 | main = do 9 | args <- getArgs 10 | case args of 11 | [] -> gene 12 | x:xs -> codeGenIO x >>= putStrLn 13 | 14 | 15 | 16 | ---- 17 | -------------------------------------------------------------------------------- /examples/codeOfGenLangs/depTypedLC.lc: -------------------------------------------------------------------------------- 1 | lam(bool, x.x) : pi(bool, x.x) 2 | -------------------------------------------------------------------------------- /examples/langSpecs/convoluted.fpl: -------------------------------------------------------------------------------- 1 | [bool] 2 | DependentSorts : 3 | tm, ty, tn 4 | 5 | FunctionalSymbols : 6 | bool : ty 7 | false : tm 8 | true : tm 9 | if : (ty, 1) * (tm, 0) * (tm, 0) * (tm, 0) -> tm 10 | lam : (ty , 0) * (tm , 1) -> tm 11 | app : (tm , 0) * (tm , 0) * (ty, 1) -> tm 12 | pi : (ty, 0) * (ty, 1) -> ty 13 | sigma : (tm,0) * (tm, 0) * (ty, 1) * (ty, 2) -> tm 14 | ff : (ty, 0) * (tm, 0) -> ty 15 | gf : (ty, 0) * (ty, 2) -> tm 16 | rf : (ty, 0) * (ty, 2) -> ty 17 | 18 | Axioms : 19 | Tr = 20 | |--- |- true : bool 21 | 22 | GRule = 23 | forall S : ty, (x y).T : ty 24 | x : S, y : S |- T def |--- |- gf(S, (x y).T) : rf(S, (x y).T) 25 | 26 | RRule = 27 | forall S : ty, (x y).T : ty 28 | x : S, y : S |- T def |--- |- rf(S, (x y).T) def 29 | 30 | FRule = 31 | forall S : ty, t : tm, T : ty 32 | x:S, y:S |- t : T, 33 | x:T |- t : bool, 34 | |- gf(S, (x z).rf(T, (y r).T)) : rf(S, (x z).T) 35 | |----------------- 36 | |- ff(S, t) def 37 | 38 | Fls = 39 | |--- |- false : bool 40 | 41 | Bool = 42 | |--- |- bool def 43 | 44 | If-then = 45 | forall t : tm, t1 : tm, t2 : tm, x.A : ty 46 | x : bool |- A def, |- t1 : A[x:=true], |- t2 : A[x:=false], |- t : bool |--- |- if(x.A, t, t1, t2) : A[x:=t] 47 | 48 | K-Pi = 49 | forall T1 : ty , x.T2 : ty 50 | x : T1 |- T2 def |--- |- pi(T1, x.T2) def 51 | 52 | TAbs = 53 | forall S : ty , x.T : ty , x.t : tm 54 | x : S |- t : T |--- |- lam(S , x.t) : pi(S , x.T) 55 | 56 | TApp = 57 | forall t1 : tm , t2 : tm , S : ty, x.T : ty 58 | |- t1 : pi(S, x.T) , |- t2 : S, x : S |- T def |---- |- app(t1 , t2, x.T) : T[x:=t2] 59 | 60 | TSig = 61 | forall t1 : tm , t2 : tm , z.S : ty, (x y).T : ty 62 | z : bool |- t1 : pi(S, x.T[y:=true]) , 63 | z : bool |- t2 : S , 64 | z : bool, x : S, y: S |- T def 65 | |------------------------------------------------ 66 | |- sigma(t1, t2, z.S, (y x).T) : T[x:=t2][y:= t2] 67 | 68 | Reductions : 69 | Beta = 70 | forall x.b : tm, A : ty, a : tm, z.T : ty 71 | |--- |- app(lam(A , x.app(a, b, z.T)) , a, z.T) => b[x := a] -- : T[z:=a] 72 | 73 | IfRed1 = 74 | forall x.A : ty, f : tm , r : tm 75 | |--- |- if(x.A, true, f, r) => f -- : A[x:=true] 76 | 77 | IfRed2 = 78 | forall x.A : ty, f : tm , g : tm 79 | |--- |- if(x.A, false, f, g) => g -- : A[x:=true] 80 | 81 | 82 | 83 | -- 84 | -------------------------------------------------------------------------------- /examples/langSpecs/depTypedLC.fpl: -------------------------------------------------------------------------------- 1 | DependentSorts : 2 | tm, ty 3 | 4 | FunctionalSymbols : 5 | bool : ty 6 | false : tm 7 | true : tm 8 | if : (ty, 1) * (tm, 0) * (tm, 0) * (tm, 0) -> tm 9 | lam : (ty , 0) * (tm , 1) -> tm 10 | app : (tm , 0) * (tm , 0) * (ty, 1) -> tm 11 | pi : (ty, 0) * (ty, 1) -> ty 12 | Axioms : 13 | Tr = 14 | |--- |- true : bool 15 | 16 | Fls = 17 | |--- |- false : bool 18 | 19 | Bool = 20 | |--- |- bool def 21 | 22 | If-then = 23 | forall t : tm, t1 : tm, t2 : tm, x.A : ty 24 | x : bool |- A def, |- t1 : A[x:=true], |- t2 : A[x:=false], |- t : bool |--- |- if(x.A, t, t1, t2) : A[x:=t] 25 | 26 | K-Pi = 27 | forall T1 : ty , x.T2 : ty 28 | x : T1 |- T2 def |--- |- pi(T1, x.T2) def 29 | 30 | TAbs = 31 | forall S : ty , x.T : ty , x.t : tm 32 | x : S |- t : T |--- |- lam(S , x.t) : pi(S , x.T) 33 | 34 | TApp = 35 | forall t1 : tm , t2 : tm , S : ty, x.T : ty 36 | |- t1 : pi(S, x.T) , |- t2 : S , x : S |- T def |---- |- app(t1 , t2, x.T) : T[x:=t2] 37 | 38 | Reductions : 39 | Beta = 40 | forall x.b : tm, A : ty, a : tm, z.T : ty 41 | |--- |- app(lam(A , x.b), a, z.T) => b[x := a] -- : T[z:=a] 42 | 43 | IfRed1 = 44 | forall x.A : ty, f : tm , g : tm 45 | |--- |- if(x.A, true, f, g) => f : A[x:=true] 46 | 47 | IfRed2 = 48 | forall x.A : ty, f : tm , g : tm 49 | |--- |- if(x.A, false, f, g) => g : A[x:=true] 50 | 51 | 52 | -- 53 | -------------------------------------------------------------------------------- /examples/tests/fail/almost.fpl: -------------------------------------------------------------------------------- 1 | DependentSorts : -- meaning context dependent 2 | tm, tn -- all depsorts depend on tm, (tm must always exist) tm always dependent 3 | 4 | SimpleSorts : 5 | ty -- ty should always exist, mb dep mb indep 6 | 7 | FunctionalSymbols : 8 | arr : ty * ty -> ty 9 | cart : (tn , 0) * (tn , 0) -> tn 10 | pi : (tn , 0) * (tn , 1) -> tn -- B : A -> U, we have B(x) - so we need x in our context 11 | sigma : (tn , 0) * (tn , 1) -> tn 12 | lam : ty * (tm , 1) -> tm 13 | app : (tm , 0) * (tm , 0) -> tm 14 | 15 | Reductions: 16 | Beta = 17 | forall x.b : tm , A : ty, a : tm 18 | |--- |- app(lam(A, x.b), a) => b [x := a] 19 | 20 | 21 | 22 | 23 | 24 | -------------------------- 25 | -------------------------------------------------------------------------------- /examples/tests/fail/example.fpl: -------------------------------------------------------------------------------- 1 | -- <- comment, indent is meaningful 2 | 3 | DependentSorts : -- meaning context dependent 4 | tm, tn -- all depsorts depend on tm, (tm must always exist) tm always dependent 5 | 6 | SimpleSorts : 7 | ty -- ty should always exist, mb dep mb indep 8 | 9 | FunctionalSymbols : 10 | arr : ty * ty -> ty 11 | cart : (tn , 0) * (tn , 0) -> tn 12 | pi : (tn , 0) * (tn , 1) -> tn -- B : A -> U, we have B(x) - so we need x in our context 13 | sigma : (tn , 0) * (tn , 1) -> tn 14 | lam : ty * (tm , 1) -> tm 15 | app : (tm , 0) * (tm , 0) -> tm 16 | 17 | Axioms : 18 | -- (tm , 0) -- means \x -> x; (tm , 1) \x -> y, var always term 19 | 20 | AxiomOne = 21 | ------ b : (tm , 1) -- to little info, need to know variable names in context of b 22 | forall A : ty , B : ty , x.b : tm 23 | x : A |- b : B |--- |- lam(A , (x y). b) : arr(A , B) 24 | -- incorrect, not typecheck, needs (tm , 1) 25 | 26 | AxiomTwo = 27 | forall (x y).b : tm , B : ty , A : ty, a : tm 28 | y : A, x : A |- b : B , |- a : A |---- y : A |- app( lam(A , x.b) , a) : B 29 | 30 | AxiomThree = 31 | forall (x y).b : tm , z.B : tn , A : ty -- meta ":" - for sorts 32 | y: A, x : A |- b : B , |- a : A |--- |- app( lam(A , (y x).b[x:=a]) , a) : B [ z := a ] 33 | 34 | DepApp = 35 | forall x.B : ty, A : ty, e1 : tm , e2 : tm 36 | |- e1 : pi(A , x.B) , |- e2 : A |--- |- app(e1 , e2) : B[ x := e2 ] 37 | 38 | 39 | Reductions: 40 | Beta = 41 | forall x.b : tm , A : ty, a : tm 42 | |--- |- app(lam(A, x.b), a) => b [x := a] 43 | 44 | 45 | 46 | 47 | 48 | -------------------------- 49 | -------------------------------------------------------------------------------- /examples/tests/fail/example2.fpl: -------------------------------------------------------------------------------- 1 | -- <- comment, indent is meaningful 2 | 3 | DependentSorts : -- meaning context dependent 4 | tm, ty -- all depsorts depend on tm, (tm must always exist) tm always dependent 5 | 6 | FunctionalSymbols : 7 | arr : (ty, 0) * (ty, 0) -> ty 8 | cart : (ty , 0) * (ty , 0) -> ty 9 | pi : (ty , 0) * (ty , 1) -> ty -- B : A -> U, we have B(x) - so we need x in our context 10 | sigma : (ty , 0) * (ty , 1) -> ty 11 | lam : (ty, 0) * (tm , 1) -> tm 12 | app : (tm , 0) * (tm , 0) -> tm 13 | 14 | Axioms : 15 | -- (tm , 0) -- means \x -> x; (tm , 1) \x -> y, var always term 16 | 17 | AxiomThree = 18 | forall (x y).b : tm , z.B : ty , A : ty, a : tm -- meta ":" - for sorts 19 | y: A, x : A, z : A |- B def , |- a : A |--- x : A |- lam(A , y.b) : B [ z := a ] 20 | 21 | DepApp = 22 | forall x.B : ty, A : ty, e1 : tm , e2 : tm 23 | |- e1 : pi(A , x.B) , |- e2 : A |--- |- app(e1 , e2) : B[ x := e2 ] 24 | 25 | 26 | Reductions: 27 | Beta = 28 | forall x.b : tm , A : ty, a : tm 29 | |--- |- app(lam(A, x.b), a) => b [x := a] 30 | 31 | 32 | 33 | 34 | 35 | -------------------------- 36 | -------------------------------------------------------------------------------- /examples/tests/fail/tst1.fpl: -------------------------------------------------------------------------------- 1 | DependentSorts : 2 | tm, ty, tn 3 | 4 | FunctionalSymbols : 5 | bool : ty 6 | false : tm 7 | true : tm 8 | if : (ty, 1) * (tm, 0) * (tm, 0) * (tm, 0) -> tm 9 | lam : (ty , 0) * (tm , 1) -> tm 10 | app : (tm , 0) * (tm , 0) * (ty, 1) -> tm 11 | pi : (ty, 0) * (ty, 1) -> ty 12 | sigma : (ty, 0) * (ty, 2) * (tm, 0) * (tm, 0) -> tm 13 | Axioms : 14 | Tr = 15 | forall 16 | |--- |- true : bool 17 | 18 | Fls = 19 | forall 20 | |--- |- false : bool 21 | 22 | Bool = 23 | forall 24 | |--- |- bool def 25 | 26 | If-then = 27 | forall t : tm, t1 : tm, t2 : tm, x.A : ty 28 | x : bool |- A def, |- t1 : A[x:=true], |- t2 : A[x:=false], |- t : bool |--- |- if(x.A, t, t1, t2) : A[x:=t] 29 | 30 | K-Pi = 31 | forall T1 : ty , x.T2 : ty 32 | x : T1 |- T2 def |--- |- pi(T1, x.T2) def 33 | 34 | TAbs = 35 | forall S : ty , x.T : ty , x.t : tm 36 | x : S |- t : T |--- |- lam(S , x.t) : pi(S , x.T) 37 | 38 | -- [Stable - Bool] 39 | TApp = 40 | forall t1 : tm , t2 : tm , S : ty, x.T : ty 41 | |- t1 : pi(S, x.T) , |- t2 : S |---- |- app(t1 , t2, x.T) : T[x:=t2] 42 | 43 | TSig = 44 | forall t1 : tm , t2 : tm , S : ty, (x y).T : ty, A : ty 45 | |- t1 : pi(S, x.T[y:=true]) , x : A, y : A |- t2 : S |---- |- sigma(A, (y x).T, t2, t1) : T[x:=t2][y:= t2] 46 | 47 | Reductions : 48 | Beta = -- not impl 49 | forall x.b : tm, A : ty, a : tm, x.T : ty 50 | x : A |- b : T, |- a : A |--- |- app(lam(A , x.b) , a) => b [x := a] : T[x:=a] 51 | 52 | IfRed = 53 | forall x.A : ty, f : tm , g : tm 54 | |--- |- if(x.A, true, f, g) => f : A[x:=true] 55 | 56 | -- 57 | 58 | -- Есть связь между forall x.t, x.T? 59 | -- t1 : lam(S, x.app(t, T)) как вытащить T? 60 | -------------------------------------------------------------------------------- /examples/tests/pass/tst1.fpl: -------------------------------------------------------------------------------- 1 | DependentSorts : 2 | tm, ty, tn 3 | 4 | FunctionalSymbols : 5 | bool : ty 6 | false : tm 7 | true : tm 8 | if : (ty, 1) * (tm, 0) * (tm, 0) * (tm, 0) -> tm 9 | lam : (ty , 0) * (tm , 1) -> tm 10 | app : (tm , 0) * (tm , 0) * (ty, 1) -> tm 11 | pi : (ty, 0) * (ty, 1) -> ty 12 | sigma : (ty, 0) * (ty, 2) * (tm, 0) * (tm, 0) -> tm 13 | Axioms : 14 | Tr = 15 | forall 16 | |--- |- true : bool 17 | 18 | Fls = 19 | forall 20 | |--- |- false : bool 21 | 22 | Bool = 23 | forall 24 | |--- |- bool def 25 | 26 | If-then = 27 | forall t : tm, t1 : tm, t2 : tm, x.A : ty 28 | x : bool |- A def, |- t1 : A[x:=true], |- t2 : A[x:=false], |- t : bool |--- |- if(x.A, t, t1, t2) : A[x:=t] 29 | 30 | K-Pi = 31 | forall T1 : ty , x.T2 : ty 32 | x : T1 |- T2 def |--- |- pi(T1, x.T2) def 33 | 34 | TAbs = 35 | forall S : ty , x.T : ty , x.t : tm 36 | x : S |- t : T |--- |- lam(S , x.t) : pi(S , x.T) 37 | 38 | -- [Stable - Bool] 39 | TApp = 40 | forall t1 : tm , t2 : tm , S : ty, x.T : ty 41 | |- t1 : pi(S, x.T) , |- t2 : S |---- |- app(t1 , t2, x.T) : T[x:=t2] 42 | 43 | TSig = 44 | forall t1 : tm , t2 : tm , S : ty, (x y).T : ty, A : ty 45 | |- t1 : pi(S, x.T[y:=true]) , x : A, y : A |- t2 : S |---- |- sigma(A, (y x).T, t2, t1) : T[x:=t2][y:= t2] 46 | 47 | Reductions : 48 | Beta = -- not impl 49 | forall x.b : tm, A : ty, a : tm, x.T : ty 50 | x : A |- b : T, |- a : A |--- |- app(lam(A , x.b) , a) => b [x := a] : T[x:=a] 51 | 52 | IfRed = 53 | forall x.A : ty, f : tm , g : tm 54 | |--- |- if(x.A, true, f, g) => f : A[x:=true] 55 | 56 | -- 57 | 58 | -- Есть связь между forall x.t, x.T? 59 | -- t1 : lam(S, x.app(t, T)) как вытащить T? 60 | -------------------------------------------------------------------------------- /fpl-exploration-tool.cabal: -------------------------------------------------------------------------------- 1 | name: fpl-exploration-tool 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/githubuser/fpl-exploration-tool#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2016 Author name here 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src/specLang 18 | , src/specLang/parsLex 19 | , src/langGenerator 20 | , src/langGenerator/GeneratorTemplates 21 | , src/langGenerator/Default 22 | exposed-modules: CodeGen 23 | , SortCheck 24 | build-depends: base >= 4.7 && < 5 25 | , array == 0.5.1.* 26 | , mtl == 2.2.* 27 | , containers == 0.5.* 28 | , transformers == 0.5.* 29 | , transformers-compat >= 0.5 30 | , lens >= 4.14 31 | , prelude-extras >= 0.4.0.3 32 | , deriving-compat >= 0.3.5 33 | , haskell-src-exts-simple >= 1.19.0.0 34 | default-language: Haskell2010 35 | 36 | executable fpl-exploration-tool-exe 37 | hs-source-dirs: app 38 | , src/specLang 39 | , src/specLang/parsLex 40 | , src/langGenerator 41 | , src/langGenerator/GeneratorTemplates 42 | , src/langGenerator/Default 43 | main-is: Main.hs 44 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 45 | build-depends: base >= 4.7 && < 5 46 | , array == 0.5.1.* 47 | , mtl == 2.2.* 48 | , containers == 0.5.* 49 | , transformers == 0.5.* 50 | , transformers-compat >= 0.5 51 | , lens >= 4.14 52 | , prelude-extras >= 0.4.0.3 53 | , deriving-compat >= 0.3.5 54 | , haskell-src-exts-simple >= 1.19.0.0 55 | default-language: Haskell2010 56 | 57 | test-suite fpl-exploration-tool-test 58 | type: exitcode-stdio-1.0 59 | hs-source-dirs: test 60 | main-is: Spec.hs 61 | build-depends: base 62 | , fpl-exploration-tool 63 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 64 | default-language: Haskell2010 65 | 66 | source-repository head 67 | type: git 68 | location: https://github.com/githubuser/fpl-exploration-tool 69 | -------------------------------------------------------------------------------- /rules.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/esengie/fpl-exploration-tool/bf655e65d215da4d7cae703dda7a7fde1a180b43/rules.pdf -------------------------------------------------------------------------------- /src/langGenerator/CodeGen.hs: -------------------------------------------------------------------------------- 1 | module CodeGen( 2 | codeGenIO 3 | , gene 4 | -- , module X 5 | ) where 6 | 7 | import Control.Monad.State 8 | import Control.Monad.Reader 9 | import Data.Map as Map 10 | import Control.Applicative (liftA3) 11 | 12 | import Control.Monad.Except (throwError, lift) 13 | import Language.Haskell.Exts.Simple 14 | import Control.Lens 15 | 16 | import SortCheck 17 | import AST.Axiom as Ax 18 | import AST.Reduction as Red 19 | 20 | import CodeGen.Common as X 21 | import CodeGen.ADT 22 | import CodeGen.MonadInstance 23 | import CodeGen.Infer as X 24 | import CodeGen.Nf as X 25 | import CodeGen.ConsCtx as X 26 | 27 | -------------------------------------------------------------------------------- 28 | -- Main place 29 | -------------------------------------------------------------------------------- 30 | genIO :: FilePath -> FilePath -> IO String 31 | genIO template spec = do 32 | st <- sortCheckIO spec 33 | case st of 34 | Left msg -> putStrLn ("Sortcheck error: " ++ msg) >> return "err" 35 | Right st' -> do 36 | k <- parseFile template -- could Fail to parse 37 | let m = liftA3 runGenM (buildModule <$> k) (pure st') k 38 | case m of 39 | ParseFailed _ msg -> putStrLn ("Parse error: " ++ msg) >> return "err" 40 | ParseOk (Left msg) -> putStrLn ("Codegen error: " ++ msg) >> return "err" 41 | ParseOk (Right m') -> return $ prettyPrint m' 42 | 43 | templateFile = "src/langGenerator/GeneratorTemplates/LangTemplate.hs" 44 | 45 | codeGenIO :: FilePath -> IO String 46 | codeGenIO = genIO templateFile 47 | 48 | gene :: IO () 49 | gene = codeGenIO "examples/langSpecs/convoluted.fpl" >>= putStrLn 50 | 51 | -------------------------------------------------------------------------------- 52 | 53 | buildModule :: Module -> GenM Module 54 | buildModule (Module (Just (ModuleHead _ v1 v2)) b c _) = do 55 | ------------ 56 | symtab <- ask 57 | unless (all (== Nothing) $ Red.stab <$> (Map.elems $ symtab^.SortCheck.reductions)) $ 58 | throwError "As of now all reductions are stable" 59 | ----------------------------------------------------------- 60 | genTerms 61 | genSortTypes 62 | genMonad 63 | -- genConsCtx 64 | genInfer 65 | genNf 66 | decl <- lift $ gets decls 67 | return (Module (Just (ModuleHead (ModuleName "Lang") v1 v2)) b c decl) 68 | buildModule x = return x 69 | 70 | 71 | 72 | 73 | 74 | 75 | --- 76 | -------------------------------------------------------------------------------- /src/langGenerator/CodeGen/ADT.hs: -------------------------------------------------------------------------------- 1 | module CodeGen.ADT( 2 | genTerms, 3 | genSortTypes 4 | ) where 5 | 6 | import Control.Monad.Reader 7 | import Control.Monad.State 8 | import Control.Monad.Except (throwError, lift) 9 | import Language.Haskell.Exts.Simple 10 | import Control.Lens 11 | 12 | import qualified Data.Set as Set 13 | import qualified Data.Map as Map 14 | 15 | import SortCheck.SymbolTable 16 | import AST.Term hiding (Var) 17 | 18 | import CodeGen.Common 19 | 20 | -- a 21 | aVar = TyVar (Ident "a") 22 | -- = (nm ...) | ... 23 | ctorDecl nm = ConDecl (Ident nm) 24 | -- typeCtor 25 | tyCon nm = TyCon $ UnQual (Ident nm) 26 | -- unit 27 | unitT = TyCon $ Special UnitCon 28 | -- Scope 29 | scope1 = (tyCon "Scope") 30 | -- data Term a = ... 31 | termA = DataDecl DataType Nothing (DHApp (DHead (Ident "Term")) (UnkindedVar (Ident "a"))) 32 | -- Var a 33 | ctorVarA = QualConDecl Nothing Nothing (ctorDecl "Var" [aVar]) 34 | 35 | -- generates a ctor for funSym 36 | qualConDecl :: FunctionalSymbol -> QualConDecl 37 | qualConDecl (FunSym nm args _) = QualConDecl Nothing Nothing (ctorDecl (caps nm) (map conArg args)) 38 | 39 | -- Genereates ctor part for funSym arg 40 | conArg :: Sort -> Type 41 | conArg (SimpleSort nm) = TyParen (TyApp (tyCon $ sortToTyName nm) aVar) 42 | conArg (DepSort nm n) = TyParen (TyApp scoped aVar) 43 | where scoped = foldr TyApp (tyCon $ sortToTyName nm) (take n $ repeat scope1) 44 | -- conArg (DepSort nm n) = TyParen (TyApp (tyCon $ sortToTyName nm) aVar) 45 | 46 | -- take definition of AST or function and replace with modified, better one 47 | genTerms :: GenM () 48 | genTerms = do 49 | st <- ask 50 | -- this is Lens 51 | let sortsWO_tms = sortsWO_tm st 52 | let sorts = (\x -> qualConDecl $ FunSym (sortToTyCtor x) [] varSort) <$> sortsWO_tms 53 | let funSymbs = map qualConDecl $ Map.elems (st^.SortCheck.SymbolTable.funSyms) 54 | let qConDecls = (ctorVarA : sorts) ++ funSymbs 55 | let termT = termA qConDecls Nothing 56 | -- Generate data Term a = ... 57 | replaceDecls "data Term" [termT] 58 | -------------------------------------------------------------------------------- 59 | 60 | -- "Type" -> type Type = Term 61 | typeDecl :: String -> Decl 62 | typeDecl nm = TypeDecl (DHead (Ident (sortToTyName nm))) (TyCon (UnQual (Ident (sortToTyName tmName)))) 63 | 64 | genSortTypes :: GenM () 65 | genSortTypes = do 66 | st <- ask 67 | -- Generate type Type = Term, etc. 68 | let sortTypes = map typeDecl (sortsWO_tm st) 69 | replaceDecls "type Type" sortTypes 70 | 71 | 72 | 73 | 74 | 75 | 76 | --- 77 | -------------------------------------------------------------------------------- /src/langGenerator/CodeGen/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module CodeGen.Common 4 | where 5 | 6 | import Control.Monad.Reader 7 | import Control.Monad.State 8 | import Control.Monad.Except (throwError, lift) 9 | import Language.Haskell.Exts.Simple 10 | import Control.Lens 11 | 12 | import qualified Data.Char as Char 13 | import qualified Data.Set as Set 14 | 15 | import SortCheck.SymbolTable 16 | import AST.Term hiding (Var) 17 | 18 | type GenError = String 19 | type Pos = Int 20 | type VName = String 21 | type ErrorM = Either GenError 22 | 23 | data CodeGen = Gen{ 24 | count :: Int, 25 | decls :: [Decl] 26 | } 27 | 28 | -- Helpers to generate 29 | -- maybe omit this and just generate the longest binder in context 30 | data ToGen = ToGen { 31 | _swappers :: !Int, -- max(i and j) 32 | _adders :: !Int, -- i'th added 33 | _removers :: !Int, -- i'th removed 34 | _binds :: !Int 35 | } 36 | 37 | initGen :: ToGen 38 | initGen = ToGen 0 0 0 1 39 | 40 | makeLenses ''ToGen 41 | 42 | type GenM = ReaderT SymbolTable (StateT CodeGen (ErrorM)) 43 | 44 | 45 | -- looking using prettyPrint (yup) 46 | getDecl :: String -> GenM (Decl, Pos) 47 | getDecl nm = do 48 | decl <- gets decls 49 | lift . lift $ getDecl' 0 nm decl 50 | where getDecl' :: Pos -> String -> [Decl] -> ErrorM (Decl, Pos) 51 | getDecl' n nm (TypeSig{}:xs) = getDecl' (n+1) nm xs 52 | getDecl' n nm (x:xs) | take (length nm) (prettyPrint x) == nm = return (x,n) 53 | | otherwise = getDecl' (n+1) nm xs 54 | getDecl' _ nm [] = throwError $ "Haven't found " ++ nm 55 | 56 | -------------------------------------------------------------------------------- 57 | 58 | runGenM :: GenM a -> SymbolTable -> Module -> ErrorM a 59 | runGenM mon st md = evalStateT (runReaderT mon st) (Gen 0 (getDecls md)) 60 | 61 | getDecls :: Module -> [Decl] 62 | getDecls (Module _ _ _ x) = x 63 | getDecls _ = [] -- error, but whatever, we parse Modules 64 | 65 | -------------------------------------------------------------------------------- 66 | -- Helpers 67 | -------------------------------------------------------------------------------- 68 | 69 | sortToTyCtor :: String -> String 70 | sortToTyCtor x = caps x ++ "Def" 71 | 72 | fname = "f" 73 | 74 | funDecl :: String -> [[Pat]] -> [Exp] -> Decl 75 | funDecl nm pat exps = FunBind $ zipWith (\x y -> Match (Ident nm) x (UnGuardedRhs y) Nothing) pat exps 76 | 77 | sortToTyName :: String -> String 78 | sortToTyName nm 79 | | nm == tmName = "Term" 80 | | nm == tyName = "Type" 81 | | otherwise = caps nm 82 | 83 | sortsWO_tm :: SymbolTable -> [String] 84 | sortsWO_tm st = Set.toList $ (Set.delete tmName (st^.depSorts)) `Set.union` (st^.simpleSorts) 85 | 86 | caps :: String -> String 87 | caps [] = [] 88 | caps x = Char.toUpper (head x) : tail x 89 | 90 | replace :: Pos -> [a] -> [a] -> [a] 91 | replace n xs lst = (take n lst) ++ xs ++ (drop (n + 1) lst) 92 | 93 | replaceDecls :: String -> [Decl] -> GenM () 94 | replaceDecls nm res = do 95 | lst <- get 96 | (_ , n) <- getDecl nm 97 | put lst{decls = replace n res (decls lst)} 98 | 99 | 100 | dummyDecl = [((fromParseResult . parseDecl) "x = 1212312323123123213")] 101 | 102 | vars = zipWith (\x y -> x ++ show y) (repeat "v") ([1..] :: [Integer]) 103 | 104 | --- 105 | -------------------------------------------------------------------------------- /src/langGenerator/CodeGen/ConsCtx.hs: -------------------------------------------------------------------------------- 1 | module CodeGen.ConsCtx 2 | -- ( 3 | -- genInfer 4 | -- ) 5 | where 6 | 7 | import Control.Monad.Reader 8 | import Control.Monad.State 9 | import Control.Monad.Except (throwError, lift) 10 | import Language.Haskell.Exts.Simple 11 | import Control.Lens 12 | 13 | import qualified Data.Set as Set 14 | import qualified Data.Map as Map 15 | 16 | import SortCheck 17 | import AST hiding (Var, name) 18 | import qualified AST(Term(Var)) 19 | import AST.Axiom hiding (name) 20 | 21 | import CodeGen.Common 22 | import CodeGen.RightSide.Common 23 | import CodeGen.RightSide.Exprs (buildStabilityExp) 24 | 25 | errCons :: [Exp] -> Exp 26 | errCons = appFun (var $ name "consErr") 27 | 28 | genConsCtx :: GenM () 29 | genConsCtx = do 30 | stab <- reader _stabs 31 | stab' <- lift . lift $ runBM Map.empty $ buildStabilityExp stab 32 | case stab' of 33 | Nothing -> return () 34 | Just x -> do 35 | let res = consCtx x 36 | replaceDecls "consCtx" [res] 37 | 38 | consCtx :: Exp -> Decl 39 | consCtx lst = funDecl "consCtx" [pvar . name <$> vars] [If check trueCons $ errCons [varX, lst]] 40 | where 41 | vars = ["x", "ct", "var"] 42 | varX = var $ name "x" 43 | check = appFun (var $ name "elem") [varX, lst] 44 | trueCons = appFun (var $ name "consCtx'") (var . name <$> vars) 45 | 46 | 47 | --- 48 | -------------------------------------------------------------------------------- /src/langGenerator/CodeGen/Infer.hs: -------------------------------------------------------------------------------- 1 | module CodeGen.Infer ( 2 | genInfer 3 | ) where 4 | 5 | import Control.Monad.Reader 6 | import Control.Monad.State 7 | import Control.Monad.Except (throwError, lift) 8 | import Language.Haskell.Exts.Simple 9 | import Control.Lens 10 | import Debug.Trace 11 | 12 | import qualified Data.Set as Set 13 | import qualified Data.Map as Map 14 | 15 | import SortCheck 16 | import AST hiding (Var, name) 17 | import qualified AST(Term(Var)) 18 | import AST.Axiom hiding (name) 19 | 20 | import CodeGen.Common 21 | import CodeGen.MonadInstance (funToPat) 22 | import CodeGen.RightSide.Infer (buildRightInfer) 23 | import CodeGen.RightSide.Helpers (tmAlias) 24 | 25 | -------------------------------------------------------------------------- 26 | 27 | fsymLeft :: FunctionalSymbol -> [Pat] 28 | fsymLeft f = [PVar (Ident "ctx"), funToPat f] 29 | 30 | fsymLeftAlias :: FunctionalSymbol -> [Pat] 31 | fsymLeftAlias f = [PVar (Ident "ctx"), PAsPat tmAlias $ funToPat f] 32 | 33 | errStarStar :: String -> Exp 34 | errStarStar str = App (Var (UnQual (Ident "report"))) (Lit (String str)) 35 | 36 | genInfer :: GenM () 37 | genInfer = do 38 | st <- ask 39 | 40 | --- Var work 41 | let varL = fsymLeft (FunSym "Var" [varSort] varSort) 42 | let varR = app (var $ name "ctx") (var $ name $ vars !! 0) 43 | ------ 44 | --- Errors of type ty(*) = * 45 | let sortsL = (\x -> fsymLeft $ FunSym (sortToTyCtor x) [] varSort) <$> sortsWO_tm st 46 | let sortsR = (errStarStar . sortToTyCtor) <$> sortsWO_tm st 47 | ------ 48 | 49 | let fsyms = Map.elems (st^.SortCheck.funSyms) 50 | let fLeft = fsymLeftAlias <$> fsyms 51 | -- We've checked our lang, can unJust 52 | let fRight' = (\f -> buildRightInfer (st^.SortCheck.funSyms) 53 | f 54 | $ (unJust . funToAx st) f) 55 | <$> fsyms 56 | fRight <- lift . lift $ sequence fRight' 57 | 58 | --- Gather and build a resulting function 59 | let res = funDecl "infer" (varL : sortsL ++ fLeft) (varR : sortsR ++ fRight) 60 | replaceDecls "infer" [res] 61 | 62 | 63 | 64 | 65 | --- 66 | -------------------------------------------------------------------------------- /src/langGenerator/CodeGen/MonadInstance.hs: -------------------------------------------------------------------------------- 1 | module CodeGen.MonadInstance( 2 | genMonad, 3 | funToPat 4 | ) where 5 | 6 | import Control.Monad.Reader 7 | import Control.Monad.State 8 | import Control.Monad.Except (throwError, lift) 9 | import Language.Haskell.Exts.Simple 10 | import Control.Lens hiding (op) 11 | 12 | import qualified Data.Map as Map 13 | 14 | import SortCheck.SymbolTable 15 | import AST.Term hiding (Var, name) 16 | 17 | import CodeGen.Common 18 | 19 | inApp a op' b = infixApp (varExp a) (qvarOp op') (varExp b) 20 | where qvarOp nm = op (sym nm) 21 | varExp nm = var (name nm) 22 | 23 | -- f(x.A, x.B, y.t) ---> ... (F v1 v2 v3) = ... 24 | funToPat :: FunctionalSymbol -> Pat 25 | funToPat (FunSym nm lst _) = PApp (UnQual (Ident (caps nm))) 26 | (map (PVar . Ident) (take (length lst) vars)) 27 | 28 | infixMatch :: FunctionalSymbol -> Exp -> Match 29 | infixMatch f@(FunSym nm lst _) exp = InfixMatch (funToPat f) 30 | (Symbol ">>=") 31 | [PVar (Ident fname)] 32 | (UnGuardedRhs exp) 33 | Nothing 34 | 35 | boundBind :: FunctionalSymbol -> Exp 36 | boundBind f@(FunSym nm lst _) = foldl App (Con (UnQual (Ident $ caps nm))) (map smart (zip lst vars)) 37 | where 38 | vn x = var (name x) 39 | smart (srt, nm) | getSortDepth srt == 0 = inApp nm ">>=" fname 40 | | getSortDepth srt == 1 = inApp nm ">>>=" fname 41 | | otherwise = appFun (vn $ "ap" ++ (show $ getSortDepth srt)) (vn <$> [nm, fname]) 42 | 43 | bindVarA :: Match 44 | bindVarA = infixMatch (FunSym "Var" [varSort] varSort) 45 | (App (Var (UnQual (Ident fname))) (Var (UnQual (Ident $ vars !! 0)))) 46 | 47 | monadTerm :: [Match] -> Decl 48 | monadTerm lst = InstDecl Nothing 49 | (IRule Nothing Nothing 50 | (IHApp (IHCon (UnQual (Ident "Monad"))) (TyCon (UnQual (Ident "Term"))))) 51 | (Just [InsDecl (FunBind lst)]) 52 | 53 | genMonad :: GenM () 54 | genMonad = do 55 | st <- ask 56 | let sorts = (\x -> FunSym (sortToTyCtor x) [] varSort) <$> sortsWO_tm st 57 | let matches = (\f -> infixMatch f (boundBind f)) <$> Map.elems (st^.SortCheck.SymbolTable.funSyms) ++ sorts 58 | let monadInst = monadTerm (bindVarA : matches) 59 | 60 | replaceDecls "instance Monad Term" [monadInst] 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | --- 70 | -------------------------------------------------------------------------------- /src/langGenerator/CodeGen/Nf.hs: -------------------------------------------------------------------------------- 1 | module CodeGen.Nf( 2 | genNf 3 | ) where 4 | 5 | import Control.Monad.Reader 6 | import Control.Monad.State 7 | import Control.Monad.Except (throwError, lift) 8 | import Language.Haskell.Exts.Simple 9 | import Control.Lens 10 | 11 | import qualified Data.Set as Set 12 | import qualified Data.Map as Map 13 | 14 | import SortCheck 15 | import AST hiding (Var, name) 16 | import qualified AST(Term(Var)) 17 | import AST.Axiom hiding (name) 18 | 19 | import CodeGen.Common 20 | import CodeGen.MonadInstance (funToPat) 21 | import CodeGen.RightSide.Nf (buildRightNf) 22 | import CodeGen.RightSide.Helpers (tyCtor) 23 | 24 | 25 | funNf' :: [Match] -> Decl 26 | funNf' ms = FunBind (ms ++ [Match (Ident "nf'") 27 | [PWildCard, pvar (name "x")] 28 | (UnGuardedRhs $ var (name "x")) 29 | Nothing]) 30 | 31 | fsymLeft :: FunctionalSymbol -> [Pat] 32 | fsymLeft f = [funToPat f] 33 | 34 | genNf :: GenM () 35 | genNf = do 36 | st <- ask 37 | 38 | --- Var work 39 | let varL = fsymLeft (FunSym "Var" [varSort] varSort) 40 | let varR = app (tyCtor "Var") (var $ name $ vars !! 0) 41 | ------ 42 | --- TyDefs 43 | let sortsL = (\x -> fsymLeft $ FunSym (sortToTyCtor x) [] varSort) <$> sortsWO_tm st 44 | let sortsR = (var . name . sortToTyCtor) <$> sortsWO_tm st 45 | ------ 46 | 47 | let fsyms = Map.elems (st^.SortCheck.funSyms) 48 | let fLeft = fsymLeft <$> fsyms 49 | -- We've checked our lang, can unJust 50 | let fRight' = (\f -> do reds <- reducts st f 51 | buildRightNf f reds) <$> fsyms 52 | fRight <- lift . lift $ sequence fRight' 53 | let nfRs = fst <$> fRight 54 | let nf'Rs = concat (snd <$> fRight) 55 | 56 | --- Gather and build a resulting function 57 | let res = funDecl "nf" (varL : sortsL ++ fLeft) (varR : sortsR ++ nfRs) 58 | replaceDecls "nf" [res] 59 | replaceDecls "nf'" [funNf' nf'Rs] 60 | 61 | 62 | 63 | 64 | --- 65 | -------------------------------------------------------------------------------- /src/langGenerator/CodeGen/RightSide/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module CodeGen.RightSide.Common 4 | where 5 | 6 | import Control.Monad.State 7 | import Control.Monad.Except (throwError, lift) 8 | import Control.Lens 9 | import Language.Haskell.Exts.Simple 10 | 11 | import qualified Data.Map as Map 12 | 13 | import AST hiding (Var, name, Name) 14 | import qualified AST (Term(Var), Name) 15 | 16 | import CodeGen.Common hiding (count) 17 | 18 | -- T def - need forall 19 | -- f() def - need funsyms 20 | 21 | data Q = Q { 22 | _count :: Int, 23 | _foralls :: Map.Map MetaVar Sort, 24 | -- metaVar as in forall(!) x.T -> (realctx, termExp) 25 | -- if we have forall x.T, but then xrt.T = term, we store x.T -> (xrt, term) 26 | _metas :: Map.Map MetaVar [(Ctx, Exp)], 27 | _doStmts :: [Stmt], -- this will be concatted 28 | 29 | -- we define some metavars on the right of :, others we need to check 30 | _juds :: Juds, 31 | -- various counters - the outer monad will have to use this 32 | _toGen :: ToGen, 33 | -- need this to get the kinds of funsyms 34 | _funsyms :: Map.Map AST.Name FunctionalSymbol 35 | } 36 | 37 | data Juds = Juds { 38 | _metaTyDefs :: [(MetaVar, Judgement)], -- some var will be added to the metas map (|- g : T) 39 | _notDefsTy :: [(Term, Judgement)], -- here it will not, so v_i <- infer ... (|- g : exp(T, G)) 40 | _otherJuds :: [Judgement] -- |- g def 41 | } 42 | 43 | makeLenses ''Juds 44 | makeLenses ''Q 45 | 46 | type BldRM = StateT Q (ErrorM) 47 | 48 | initJuds :: Juds 49 | initJuds = Juds [] [] [] 50 | 51 | runBM :: (Map.Map AST.Name FunctionalSymbol) -> BldRM a -> ErrorM a 52 | runBM fss mon = evalStateT mon (Q 0 Map.empty Map.empty [] initJuds initGen fss) 53 | 54 | fresh :: BldRM VName 55 | fresh = do 56 | i <- gets _count 57 | count += 1 58 | return (vars !! i) 59 | 60 | updateMap :: MetaVar -> (ct, v) -> Map.Map MetaVar [(ct,v)] -> Map.Map MetaVar [(ct,v)] 61 | updateMap mv (ct, ex) mp = case Map.lookup mv mp of 62 | Nothing -> Map.insert mv [(ct,ex)] mp 63 | (Just vs) -> Map.insert mv ((ct,ex):vs) mp 64 | 65 | appendExp :: Exp -> BldRM () 66 | appendExp ex = appendStmt (Qualifier ex) 67 | 68 | appendStmt :: Stmt -> BldRM () 69 | appendStmt st = doStmts %= (++ [st]) 70 | 71 | labelJudgement :: Judgement -> BldRM () 72 | labelJudgement jud = 73 | case jType jud of 74 | Nothing -> juds.otherJuds %= (jud :) 75 | Just (Meta mv) -> juds.metaTyDefs %= ((mv, jud) :) 76 | Just tm -> juds.notDefsTy %= ((tm, jud) :) 77 | 78 | 79 | --- 80 | -------------------------------------------------------------------------------- /src/langGenerator/CodeGen/RightSide/Exprs.hs: -------------------------------------------------------------------------------- 1 | module CodeGen.RightSide.Exprs( 2 | conniveMeta, 3 | trimMeta, 4 | buildTermExp, 5 | buildTermPat, 6 | buildCheckExps, 7 | buildInferExps, 8 | genCheckStability, 9 | buildStabilityExp, 10 | ) where 11 | 12 | import Control.Monad.Except (throwError, lift) 13 | import Control.Lens hiding (op) 14 | import Language.Haskell.Exts.Simple 15 | 16 | import qualified Data.Map as Map 17 | 18 | import AST hiding (Var, name, Name) 19 | import qualified AST (Term(Var), Name) 20 | 21 | import CodeGen.Common 22 | import CodeGen.RightSide.Common 23 | import CodeGen.RightSide.Helpers 24 | import CodeGen.RightSide.Solver 25 | 26 | -- [x,y,z] -> [x, x.y, xy.z] 27 | -- but it's types 28 | buildConsCtxExps :: [(VarName, Term)] -> BldRM [Exp] 29 | buildConsCtxExps lst = helper lst [] 30 | where 31 | helper :: [(VarName, Term)] -> Ctx -> BldRM [Exp] 32 | helper [] _ = return [] 33 | helper ((vn, tm): xs) ct = do 34 | ex <- buildTermExp ct tm 35 | exps <- helper xs (ct ++ [vn]) 36 | return (ex:exps) 37 | 38 | -- given x,y,z,r -> check ctx TyDef x, check (consCtx x) TyDef y ... 39 | buildCtxCheckExps :: [Exp] -> [Exp] 40 | buildCtxCheckExps xs' = helper xs' [] 41 | where 42 | helper [] _ = [] 43 | helper (x:xs) ys = appFun checkE [consCtxes (reverse ys), sortToExp tyName, x] 44 | : helper xs (x:ys) 45 | 46 | -- consCtxes ["x","y","z"] -> consCtx z (consCtx y (consCtx x ctx)) 47 | consCtxes :: [Exp] -> Exp 48 | consCtxes ctxExps = foldr (\x y -> appFun consCtxE [x,y]) ctxE (reverse ctxExps) 49 | 50 | checkHasType :: Judgement -> BldRM Term 51 | checkHasType j = case jType j of Nothing -> throwError $ show j ++ " has no type" 52 | Just x -> return x 53 | checkHasNoType :: Judgement -> BldRM () 54 | checkHasNoType j = case jType j of Nothing -> return () 55 | Just _ -> throwError $ show j ++ " has type" 56 | 57 | -- ctx, ctx, ctx, a = b >> infer cxzzczc 58 | -- x, y |- infer (consCtx y (consCtx x)) 59 | buildInferExps :: Judgement -> BldRM [Exp] 60 | buildInferExps jud = do 61 | _ <- checkHasType jud 62 | -- if we have equality, then return a func: \x -> a = b >> x (+ exp & term) 63 | (f, ex, _) <- buildEq jud 64 | ctxExps <- buildConsCtxExps (_jContext jud) 65 | let inf = appFun infE [consCtxes ctxExps, ex] 66 | let others = buildCtxCheckExps ctxExps 67 | return $ others ++ [f inf] 68 | 69 | buildEq :: Judgement -> BldRM (Exp -> Exp, Exp, Term) 70 | buildEq j@(Statement _ tm _) = do 71 | ex <- buildTermExp (judCtx j) tm 72 | return (id, ex, tm) 73 | buildEq (Reduct{}) = throwError $ "Reduct in infer is an implem error" 74 | buildEq j@(Equality _ l r _) = do 75 | let ct = judCtx j 76 | ex <- buildTermExp ct l 77 | rex <- buildTermExp ct r 78 | let eq = eqCheckExp ex rex 79 | return (\x -> infixApp eq (op (sym ">>")) x , ex, l) 80 | 81 | buildCheckExps :: Judgement -> BldRM [Exp] 82 | buildCheckExps jud = do 83 | checkHasNoType jud 84 | (f, ex, tm) <- buildEq jud 85 | ctxExps <- buildConsCtxExps (_jContext jud) 86 | 87 | st <- termSort tm 88 | let inf = if st == tmName 89 | then appFun infE [consCtxes ctxExps, ex] 90 | else appFun checkE [consCtxes ctxExps, sortToExp st, ex] 91 | 92 | let others = buildCtxCheckExps ctxExps 93 | return $ others ++ [f inf] 94 | 95 | 96 | termSort :: Term -> BldRM SortName 97 | termSort (AST.Var _) = return tmName 98 | termSort (Meta mv) = do 99 | st <- uses foralls (Map.lookup mv) 100 | case st of 101 | Nothing -> throwError $ "error in sortchecking, metavar not in foralls " ++ show mv 102 | Just s -> return (getSortName s) 103 | termSort (Subst tm _ _) = termSort tm 104 | termSort (FunApp nm _) = do 105 | st <- uses funsyms (Map.lookup nm) 106 | case st of 107 | Nothing -> throwError $ "error in sortchecking, funsym not in funsyms " ++ show nm 108 | Just s -> return (getSortName $ result s) 109 | 110 | -- we take a metavar + its' term and transform it into a metavar in different ctx 111 | -- and return the transformation (it's context manipulation xzy.T -> yxz.T) 112 | -- this is the most difficult function, builds a not scoped repr 113 | conniveMeta :: Ctx -> (Ctx, Exp) -> BldRM Exp 114 | conniveMeta ctx (oldCt, ex) = 115 | if (not $ isSubset oldCt ctx) 116 | then throwError $ 117 | "error in sortchecking or impl " ++ show oldCt ++ " isn't a subset of " ++ show ctx 118 | else do 119 | let (swaps, adds) = ctxAddLtoR oldCt ctx 120 | return $ appAdds adds (appSwaps swaps ex) 121 | 122 | appSwaps :: [Swapper] -> Exp -> Exp 123 | appSwaps lst ex' = foldl (\ex (Sw x) -> swap x ex) ex' lst 124 | 125 | appRems :: [Remover] -> Exp -> Exp 126 | appRems lst ex' = foldl (\ex (R x) -> infixApp ex (op (sym ">>=")) (rmv x)) (retExp ex') lst 127 | 128 | appAdds :: [Adder] -> Exp -> Exp 129 | appAdds lst ex = foldl (\ex' (A x) -> add x ex') ex lst 130 | 131 | trimMeta :: Ctx -> (Ctx, Exp) -> BldRM (Ctx, Exp) 132 | trimMeta ctx (oldCt, ex) = 133 | if (not $ isSubset ctx oldCt) 134 | then throwError $ 135 | "error in sortchecking or impl " ++ show ctx ++ " isn't a subset of " ++ show oldCt 136 | else do 137 | -- need only removes 138 | let (ctx', rems) = ctxTrimLtoR oldCt ctx 139 | -- a problem: we're in TC in rems, else we're in Identity! 140 | return $ (ctx', appRems rems ex) 141 | 142 | -------------------------------------------------------------------------------- 143 | -- walk the term and build it var by var 144 | -- returns as unscoped as can be 145 | buildTermExp :: Ctx -> Term -> BldRM Exp 146 | buildTermExp ctx (AST.Var vn) = lift $ buildVar ctx vn -- builds up stuff like F(F(F(F(B())))) 147 | buildTermExp ctx (Subst into vn what) = do 148 | intoE <- buildTermExp (vn:ctx) into 149 | whatE <- buildTermExp (ctx) what 150 | return $ inst1 whatE (toScope 1 intoE) -- 1 scope only 151 | buildTermExp ctx (Meta mv) = do 152 | res <- uses metas (Map.lookup mv) 153 | case res of 154 | Nothing -> throwError $ "Metavar " ++ show mv ++ " not found in terms" 155 | -- we store metavar values as list, but we fold it 156 | Just res' -> conniveMeta ctx (res' !! 0) 157 | buildTermExp ctx (FunApp nm lst) = do 158 | -- see ctx ++ ctx', differs from our treatment in subst (*) 159 | lst' <- mapM (\(ctx', tm) -> buildTermExp (ctx ++ ctx') tm) lst 160 | let lst'' = (\((ctx', _), ex) -> toScope (length ctx') ex) <$> zip lst lst' 161 | return $ appFunS nm lst'' 162 | 163 | -- (*) x.T -> lam(S, z.(lam(S, y.T[x:=true][v:=false]))) -- xvzy.T 164 | -- ctx: z -> z+y -> v+zy -> x+vzy 165 | 166 | buildTermPat :: Ctx -> Term -> BldRM Pat 167 | buildTermPat ctx (AST.Var vn) = lift $ buildVarPat ctx vn -- builds up stuff like F(F(F(F(B())))) 168 | buildTermPat _ (Subst{}) = throwError "Subst is not allowed in the left of reductions, implem error" 169 | buildTermPat ctx (Meta mv) = do 170 | vm <- fresh 171 | metas %= updateMap mv (ctx, var $ name vm) 172 | return (pvar $ name vm) 173 | buildTermPat ctx (FunApp nm lst) = do 174 | -- here's the main reason I wrote SimpleBound 175 | pats <- mapM (\(ctx', tm) -> buildTermPat (ctx ++ ctx') tm) lst 176 | let pats' = (\(ctx', p) -> unScope (length ctx') p) <$> 177 | zipWith (\(c,t) p -> (c,p)) lst pats 178 | return $ pApp (name $ caps nm) pats' 179 | 180 | genCheckStability :: Stab -> BldRM () 181 | genCheckStability sty = do 182 | styEx <- buildStabilityExp sty 183 | case styEx of 184 | Nothing -> return () 185 | Just (ex) -> appendExp $ appFun stabE [ctxE, var tmAlias, ex] 186 | 187 | buildStabilityExp :: Stab -> BldRM (Maybe Exp) 188 | buildStabilityExp Nothing = return Nothing 189 | buildStabilityExp (Just lst) = do 190 | -- note that this works, but we have to have checked 191 | -- terms contain no metavars or substs!!! 192 | exps <- mapM (buildTermExp []) lst 193 | return . pure $ listE exps 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | --- 207 | -------------------------------------------------------------------------------- /src/langGenerator/CodeGen/RightSide/Helpers.hs: -------------------------------------------------------------------------------- 1 | module CodeGen.RightSide.Helpers 2 | where 3 | 4 | import Data.List 5 | import Control.Monad.Except (throwError, lift) 6 | import Control.Lens 7 | import Language.Haskell.Exts.Simple 8 | 9 | import AST hiding (Var, name, Name) 10 | 11 | import CodeGen.Common hiding (count) 12 | 13 | appFunS :: VarName -> [Exp] -> Exp 14 | appFunS nm lst = appFun (var $ name (caps nm)) lst 15 | 16 | retExp :: Exp -> Exp 17 | retExp ex = app (var $ name "pure") $ ex 18 | 19 | eqCheckExp :: Exp -> Exp -> Exp 20 | eqCheckExp ex1 ex2 = app (app (var (name "checkEq")) ex1) ex2 21 | 22 | tyCtor :: String -> Exp 23 | tyCtor st = Con (UnQual (Ident st)) 24 | 25 | buildCnt :: Int -> Exp 26 | buildCnt 0 = tyCtor "Bot" 27 | buildCnt n = app (tyCtor "U") $ buildCnt (n-1) 28 | 29 | buildCntP :: Int -> Pat 30 | buildCntP 0 = PWildCard 31 | buildCntP n = pApp (name "U") [buildCntP (n-1)] 32 | 33 | 34 | -- txyz : x = F(F(B())) 35 | buildVar :: Ctx -> VarName -> ErrorM Exp 36 | buildVar ct vn = 37 | let fs = repeat (tyCtor "F") 38 | bb = tyCtor "B" 39 | tyCt = tyCtor "Var" 40 | in case elemIndex vn ct of 41 | Nothing -> throwError $ "Varible is not in context, sortchecking error!" 42 | Just n -> return $ foldr app bb (tyCt : take (length ct - 1 - n) fs) 43 | 44 | buildVarPat :: Ctx -> VarName -> ErrorM Pat 45 | buildVarPat ct vn = do 46 | v <- buildVar ct vn 47 | case (parsePat $ prettyPrint v) of 48 | ParseOk x -> return x 49 | _ -> throwError "lol error in buildVarPat" 50 | -- let fs = repeat (name "F") 51 | -- bb = pvar $ name "B" 52 | -- tyCt = name "Var" 53 | -- in case elemIndex vn ct of 54 | -- Nothing -> throwError $ "Varible is not in context, sortchecking error!" 55 | -- Just n -> return $ foldr (\x y -> pApp x [y]) bb (tyCt : take (length ct - 1 - n) fs) 56 | 57 | inst1 :: Exp -> Exp -> Exp -- generates instantiate v x code 58 | inst1 ex1 ex2 = appFun (var (name "instantiate")) [ex1, ex2] 59 | 60 | nf :: Int -> Exp -> Exp 61 | nf n ex | n < 1 = app (var nfN) ex 62 | | otherwise = app (var (name $ "nf" ++ show n)) ex 63 | 64 | 65 | unScope :: Int -> Pat -> Pat 66 | unScope n p | n < 1 = p 67 | | n == 1 = pApp (name "Scope") [p] 68 | | otherwise = pApp (name "Scope") [unScope (n-1) p] 69 | 70 | toScope :: Int -> Exp -> Exp 71 | toScope n ex | n < 1 = ex 72 | | n == 1 = app (var (name "toScope")) ex 73 | | otherwise = app (var (name $ "toScope" ++ show n)) ex 74 | 75 | fromScope :: Int -> Exp -> Exp 76 | fromScope n ex | n < 1 = ex 77 | | n == 1 = app (var (name "fromScope")) ex 78 | | otherwise = app (var (name $ "fromScope" ++ show n)) ex 79 | 80 | swap :: (Int, Int) -> Exp -> Exp 81 | swap (n,m) ex 82 | | n == m = ex 83 | | n > m = swap (m,n) ex 84 | | otherwise = appFun rtE [var (name $ "swap" ++ show n ++ "'" ++ show m), ex] 85 | 86 | rmv :: Int -> Exp 87 | rmv n = app travE $ var (name $ "rem" ++ show n) 88 | 89 | add :: Int -> Exp -> Exp 90 | add n ex = appFun rtE [var (name $ "add" ++ show n), ex] 91 | 92 | generator :: VarName -> Exp -> Stmt 93 | generator vn ex = Generator (PVar $ name vn) ex 94 | 95 | doExp :: [Stmt] -> Exp 96 | doExp ((Qualifier x):[]) = x 97 | doExp xs = doE xs 98 | 99 | infE = var (name "infer") 100 | checkE = var (name "checkT") 101 | ctxE = var (name "ctx") 102 | consCtxE = var (name "consCtx") 103 | rtE = var (name "rt") 104 | travE = var (name "traverse") 105 | sortToExp nm = tyCtor $ sortToTyCtor nm 106 | tmAlias = name ("al") 107 | nf'N = name "nf'" 108 | nfN = name "nf" 109 | unScopeP p = pApp (name "Scope") [p] 110 | stabE = var (name "stable") 111 | 112 | --- 113 | -------------------------------------------------------------------------------- /src/langGenerator/CodeGen/RightSide/Infer.hs: -------------------------------------------------------------------------------- 1 | module CodeGen.RightSide.Infer( 2 | buildRightInfer, 3 | populateForalls, 4 | genCheckMetaEq 5 | ) where 6 | 7 | import Control.Monad.State 8 | import Control.Monad.Except (throwError, lift) 9 | import Control.Lens 10 | import Language.Haskell.Exts.Simple 11 | 12 | import qualified Data.Map as Map 13 | 14 | import AST hiding (Var, name, Name) 15 | import qualified AST (Term(Var), Name) 16 | import AST.Axiom hiding (name) 17 | 18 | import CodeGen.Common hiding (count) 19 | import CodeGen.RightSide.Common 20 | import CodeGen.RightSide.Helpers 21 | import CodeGen.RightSide.Exprs 22 | 23 | buildRightInfer :: (Map.Map AST.Name FunctionalSymbol) -> FunctionalSymbol -> Axiom -> ErrorM Exp 24 | buildRightInfer fss fs ax = -- pure ExprHole 25 | runBM fss (buildRight' fs ax) 26 | 27 | buildRight' :: FunctionalSymbol -> Axiom -> BldRM Exp 28 | buildRight' fs ax = do 29 | genCheckStability $ stab ax 30 | -- populate foralls 31 | populateForalls (forallVars ax) 32 | -- write all metas given as args + add |- A judgements to be inferred 33 | correctFresh ax 34 | -- check metas for equality and leave only one in map if many 35 | genCheckMetaEq 36 | -- find all used Metavars + check for equality where needed 37 | -- First check all guys of the smth : T - build up the map (metavars : Term) 38 | mapM_ labelJudgement (premise ax) 39 | -- returns checks for contexts and infers the part after |- 40 | -- equality goes like this "checkEq a b >> infer (consCtx v) a" 41 | -- [[Exp]] 42 | -- [MetaVar] 43 | metaJs <- use (juds.metaTyDefs) 44 | expsMeta <- mapM (buildInferExps . snd) metaJs 45 | stmtsMeta <- mapM stmtsAndMetaLast $ zipWith 46 | (\(a,jud) c -> (a, judCtx jud,c)) 47 | metaJs expsMeta 48 | mapM_ appendStmt (concat stmtsMeta) 49 | -- check metas for equality after all of them are added 50 | genCheckMetaEq 51 | ------------------------------------------------------------------------------ 52 | ctTerms <- use (juds.notDefsTy) 53 | expsTyTms <- mapM (buildInferExps . snd) ctTerms 54 | stmtsTyTms <- mapM stmtsAndTmEqLast $ zipWith 55 | (\(a,jud) c -> (a, judCtx jud,c)) 56 | ctTerms expsTyTms 57 | mapM_ appendStmt (concat stmtsTyTms) 58 | ------------------------------------------------------------------------------ 59 | -- a = b >> check ctx TyDef expr 60 | expsDef <- join $ uses (juds.otherJuds) (mapM buildCheckExps) 61 | mapM_ appendExp (concat expsDef) 62 | 63 | genReturnSt fs (conclusion ax) 64 | uses doStmts doExp 65 | 66 | -- >>= \t -> remvars (Metavar) this 67 | stmtsAndMetaLast :: (MetaVar, Ctx, [Exp]) -> BldRM [Stmt] 68 | stmtsAndMetaLast (_, _, []) = throwError "stmtsAndMetaLast must be called with at least one expr" 69 | -- this is a metaVar def 70 | stmtsAndMetaLast (m, ct, x:[]) = do 71 | -- v_i <- x 72 | vn <- fresh 73 | let vname = var (name vn) 74 | -- trim ctx of metavar given in here and put it into the metamap 75 | -- v_i+1 <- trim v_i 76 | (mct, mvarExp) <- trimMeta (mContext m) (ct, nf 0 vname) 77 | vm <- fresh 78 | metas %= updateMap m (mct, var (name vm)) 79 | -- return first v <- infer ..., then m <- trimmed 80 | -- the benefit of using remove here is that it's in TC too, 81 | -- every other place we just use Identity monad! 82 | return [generator vn x, generator vm mvarExp] 83 | stmtsAndMetaLast (m, ct, x:xs) = do 84 | xs' <- stmtsAndMetaLast (m, ct, xs) 85 | return $ Qualifier x : xs' 86 | 87 | -- >>= \t -> remvars (Metavar) this 88 | stmtsAndTmEqLast :: (Term, Ctx, [Exp]) -> BldRM [Stmt] 89 | stmtsAndTmEqLast (_,_,[]) = throwError "stmtsAndTmEqLast must be called with at least one expr" 90 | -- this is a ": Exp" situation so we check it for equality 91 | stmtsAndTmEqLast (tm, ct, x:[]) = do 92 | vn <- fresh 93 | let vExp = var (name vn) 94 | tmExp <- buildTermExp ct tm 95 | return [generator vn x, Qualifier $ eqCheckExp tmExp vExp] 96 | stmtsAndTmEqLast (tm, ct, x:xs) = do 97 | xs' <- stmtsAndTmEqLast (tm, ct, xs) 98 | return $ Qualifier x : xs' 99 | 100 | -------------------------------------------------------------------------------- 101 | -- first vars are already used 102 | -- also axioms are always of the form like this 103 | correctFresh :: Axiom -> BldRM () 104 | correctFresh (Axiom _ _ _ prems (Statement _ (FunApp _ lst) _)) = populateSt lst 105 | where 106 | populateSt ((ct, Meta mv):xs) = do 107 | v <- fresh 108 | metas %= updateMap mv (ct, fromScope (length ct) $ var (name v)) 109 | populateSt xs 110 | -- user may have not added these 111 | when (null ct && not (elem mv (concat $ ctMetas <$> prems))) $ 112 | juds.otherJuds %= (Statement [] (Meta mv) Nothing : ) 113 | 114 | populateSt [] = return () 115 | populateSt _ = throwError "Can't have a non metavariable in an axiom concl" 116 | correctFresh _ = throwError $ "error: Only axioms with funsym intro are allowed" 117 | 118 | populateForalls :: [(MetaVar, Sort)] -> BldRM () 119 | populateForalls [] = return () 120 | populateForalls ((m, sort):xs) = do 121 | foralls %= Map.insert m sort 122 | populateForalls xs 123 | 124 | -------------------------------------------------------------------------------- 125 | -- Check terms for equality 126 | genCheckMetaEq :: BldRM () 127 | genCheckMetaEq = do 128 | ms <- gets _metas 129 | metas <~ sequence (genMetaEq <$> ms) 130 | -- metas .= res 131 | 132 | -- generate code for meta equality checking 133 | genMetaEq :: [(Ctx, Exp)] -> BldRM [(Ctx, Exp)] 134 | genMetaEq [] = return [] 135 | genMetaEq (x : []) = return [x] 136 | genMetaEq (tm : y'@(ct2, y) : xs) = do 137 | ex <- conniveMeta ct2 tm 138 | let ex' = eqCheckExp ex y 139 | appendExp ex' 140 | genMetaEq (y' : xs) 141 | 142 | -------------------------------------------------------------------------------- 143 | genReturnSt :: FunctionalSymbol -> Judgement -> BldRM () 144 | genReturnSt (FunSym _ _ res) (Statement _ _ Nothing) = do 145 | appendExp $ retExp (tyCtor $ sortToTyCtor $ getSortName res) 146 | genReturnSt _ (Statement _ _ (Just ty)) = do 147 | ret <- buildTermExp [] ty 148 | appendExp $ retExp ret 149 | genReturnSt _ _ = throwError "Can't have anything but Statement in conclusion" 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | --- 162 | -------------------------------------------------------------------------------- /src/langGenerator/CodeGen/RightSide/Nf.hs: -------------------------------------------------------------------------------- 1 | module CodeGen.RightSide.Nf( 2 | buildRightNf 3 | ) where 4 | 5 | import Control.Monad.State 6 | import Control.Monad.Except (throwError, lift) 7 | import Control.Lens 8 | import Language.Haskell.Exts.Simple 9 | import Debug.Trace 10 | 11 | import qualified Data.Map as Map 12 | 13 | import AST hiding (Var, name, Name) 14 | import qualified AST (Term(Var), Name, name) 15 | import AST.Reduction hiding (name) 16 | 17 | import CodeGen.Common hiding (count) 18 | import CodeGen.RightSide.Common 19 | import CodeGen.RightSide.Helpers 20 | import CodeGen.RightSide.Exprs 21 | import CodeGen.RightSide.Infer 22 | 23 | -- returns a pair (nf right side, nf' binds as many as judgments passed) 24 | buildRightNf :: FunctionalSymbol -> [Reduction] -> ErrorM (Exp, [Match]) 25 | buildRightNf (AST.FunSym nm args _) [] = do 26 | let nfRight = appFunS nm (normalise $ AST.getSortDepth <$> args) 27 | return (nfRight, []) 28 | buildRightNf (AST.FunSym nm args _) xs = do 29 | let nfRight = appFunS nm (normalise $ AST.getSortDepth <$> args) 30 | let n = length xs 31 | let nfRight' = appFun (var nf'N) [buildCnt n, nfRight] 32 | 33 | let cnts = reverse (take n [0..]) 34 | matches <- mapM (\(cnt, j) -> runBM Map.empty (buildNf' cnt j)) (zip cnts xs) 35 | 36 | return (nfRight', matches) 37 | 38 | 39 | buildNf' :: Int -> Reduction -> BldRM Match 40 | buildNf' cnt red = do 41 | -- genCheckStability $ stab red 42 | -- populate foralls 43 | populateForalls (forallVars red) 44 | -- gen left side & write all metas given as args -- don't mess with contexts 45 | leftFun <- buildLeft (cnt + 1) (conclusion red) 46 | -- shorten & check metas for equality and leave only one in map if many 47 | -- xyc.Z -> forallCtx(Z) 48 | genShortenMetas 49 | genCheckMetaEq 50 | genReturnSt (conclusion red) 51 | -- this time we get the stms and wrap them in 'case' exp 52 | inside <- uses doStmts doExp 53 | 54 | -- mets <- uses metas (\m -> (\(x, c) -> (x,fst <$> c)) <$> Map.toList m) 55 | -- trace (show mets) $ 56 | return $ Match nf'N 57 | leftFun 58 | (UnGuardedRhs $ caseRight cnt inside) 59 | Nothing 60 | 61 | -------------------------------------------------------------------------------- 62 | -- only conceptually different part from infer 63 | buildLeft :: Int -> Judgement -> BldRM [Pat] 64 | buildLeft n (Reduct _ l _ _) = do 65 | pat <- buildTermPat [] l 66 | return [buildCntP n, PAsPat tmAlias pat] 67 | 68 | buildLeft _ _ = throwError "Can't have anything but Reduct in conclusion" 69 | 70 | -------------------------------------------------------------------------------- 71 | -- we're in nf, no need to nf like in infer case 72 | genShortenMetas :: BldRM () 73 | genShortenMetas = do 74 | -- (meta, [(ctx, exp)]) 75 | mets <- uses metas (Map.toList) 76 | mapM_ genShortenMeta mets 77 | 78 | genShortenMeta :: (MetaVar, [(Ctx, Exp)]) -> BldRM () 79 | genShortenMeta (mv@(MetaVar ctx _), lst) = do 80 | freshs <- replicateM (length lst) fresh 81 | exps <- mapM (trimMeta ctx) lst 82 | 83 | let v_to_ex = zipWith (\f (_, ex) -> (f,ex)) freshs exps 84 | mapM_ (appendStmt . (uncurry generator)) v_to_ex 85 | 86 | let new_exps = zipWith (\f (ct, _) -> (ct, var $ name f)) freshs exps 87 | metas %= Map.insert mv new_exps 88 | 89 | -------------------------------------------------------------------------------- 90 | genReturnSt :: Judgement -> BldRM () 91 | genReturnSt (Reduct _ _ r _) = do 92 | ret <- buildTermExp [] r 93 | appendExp $ retExp ret 94 | genReturnSt _ = throwError "Can't have anything but Reduct in conclusion" 95 | 96 | -------------------------------------------------------------------------------- 97 | -- given a funsym generates its' args' normalisations according to their ctx 98 | normalise :: [ContextDepth] -> [Exp] 99 | normalise lst = (\(n, v) -> nf n (var $ name v)) <$> lst' 100 | where lst' = zip lst vars 101 | 102 | 103 | -- given a do block in Either wraps it into a case, Right x -> x 104 | caseRight :: Int -> Exp -> Exp 105 | caseRight cnt ex = caseE ex [alt (pApp (name "Left") [PWildCard]) 106 | (nonMatch cnt), 107 | alt (pApp (name "Right") [pvar $ name "x"]) 108 | (app (var nfN) $ var (name "x"))] 109 | 110 | -- feed it (U(U(U(U(U(Bot)))))) to rec call in case of failure 111 | -- we must call one less than us, so if we are number 1 out of 3 112 | -- we call U(U(Bot)) 113 | nonMatch :: Int -> Exp 114 | nonMatch n = appFun (var nf'N) [buildCnt n, var tmAlias] 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | -- 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | --- 137 | -------------------------------------------------------------------------------- /src/langGenerator/CodeGen/RightSide/Solver.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module CodeGen.RightSide.Solver( 4 | ctxAddLtoR, 5 | ctxTrimLtoR, 6 | Adder(..), 7 | Remover(..), 8 | Swapper(..) 9 | ) where 10 | 11 | import Data.List (elemIndex, elem) 12 | import Data.Maybe (fromJust) 13 | 14 | import AST(Ctx) 15 | 16 | newtype Adder = A Int 17 | deriving (Show, Eq, Num) 18 | 19 | newtype Swapper = Sw (Int, Int) 20 | deriving (Show, Eq) 21 | 22 | newtype Remover = R Int 23 | deriving (Show, Eq, Num) 24 | 25 | -- this will be minimal as anything in number of funcs generated 26 | -- number of swaps - well you could quicksort, but feck it 27 | -- Prem: list are equal as sets, no dups 28 | -- swapLtoR "abcdef" "cbaefd" = [Sw (1,3),Sw (4,5),Sw (5,6)] 29 | swapLtoR :: Eq a => [a] -> [a] -> [Swapper] 30 | swapLtoR l r = helper l r 1 31 | where 32 | helper [] [] _ = [] 33 | helper (x:xs) (y:ys) n 34 | | x == y = helper xs ys (n+1) 35 | | otherwise = 36 | let j = elemN y (x:xs) 37 | in Sw (n, n + j) : helper ys (drop 1 $ swapElementsAt 0 j (x:xs)) (n+1) 38 | 39 | -- Prem: r is sublist of l, remove all that are not in r 40 | -- remLtoR "axyvrze" "xz" == [R 1,R 2,R 2,R 2,R 3] 41 | remLtoR :: Eq a => [a] -> [a] -> [Remover] 42 | remLtoR [] _ = [] 43 | remLtoR (x:xs) ys 44 | | x `elem` ys = map (+1) (remLtoR xs ys) 45 | | otherwise = R 1 : remLtoR xs ys 46 | 47 | 48 | -- Prem: l is sublist of r && shortenLtoR r l == l 49 | -- => addLtoR l r = r, addLtoR = inv(remLtoR) 50 | -- addLtoR "xz" "axyvrze" == [A 3,A 2,A 2,A 2,A 1] 51 | addLtoR :: Eq a => [a] -> [a] -> [Adder] 52 | addLtoR l r = reverse (helper l r 1) 53 | where 54 | helper _ [] _ = [] 55 | helper [] (y:ys) n = A n : helper [] ys n 56 | helper (x:xs) (y:ys) n 57 | | x == y = helper xs ys (n + 1) 58 | | otherwise = A n : helper (x:xs) ys n 59 | 60 | -- Prem: l > r (in a sense of sets), out: l==r in a sense of sets 61 | shortenLtoR :: Eq a => [a] -> [a] -> [a] 62 | shortenLtoR [] _ = [] 63 | shortenLtoR _ [] = [] 64 | shortenLtoR (x:xs) ys 65 | | x `elem` ys = x : shortenLtoR xs ys 66 | | otherwise = shortenLtoR xs ys 67 | 68 | -- given ctx l we want it to be like r 69 | -- Prem: r in l, out: sequence of removes and then swaps to get us r 70 | -- ctxRemLtoR ["x", "z", "y"] ["x", "y"] == ([R 2],[]) 71 | -- ctxRemLtoR ["y", "b", "z", "x"] ["z", "x", "y"] == ([R 3],[Sw(1,3), Sw(2,3)]) 72 | ctxRemLtoR :: Ctx -> Ctx -> ([Remover], [Swapper]) 73 | ctxRemLtoR l r = (removed, swapped) 74 | where 75 | (l',r') = (reverse l, reverse r) 76 | removed = remLtoR l' r' 77 | shortL = shortenLtoR l' r' 78 | swapped = swapLtoR shortL r' 79 | 80 | -- in put app we only need to trim 81 | -- ctxTrimLtoR ["y", "b", "z", "x"] ["z", "x", "y"] = (["y", "z", "x"], [R 3]) 82 | ctxTrimLtoR :: Ctx -> Ctx -> (Ctx, [Remover]) 83 | ctxTrimLtoR l r = (reverse newct, removed) 84 | where 85 | (l',r') = (reverse l, reverse r) 86 | removed = remLtoR l' r' 87 | newct = shortenLtoR l' r' 88 | 89 | -- given ctx l we want it to be like r 90 | -- Prem: l in r, out: sequence of swaps then adds to get us r 91 | -- ctxAddLtoR ["x", "y"] ["x", "z", "y"] == ([],[A 2]) 92 | -- ctxAddLtoR ["z", "x", "y"] ["y", "b", "z", "x"] == ([Sw(1,2), Sw(2,3)], [A 3]) 93 | ctxAddLtoR :: Ctx -> Ctx -> ([Swapper], [Adder]) 94 | ctxAddLtoR l r = (swapped, added) 95 | where 96 | (l',r') = (reverse l, reverse r) 97 | shortR = shortenLtoR r' l' 98 | swapped = swapLtoR l' shortR 99 | added = addLtoR shortR r' 100 | 101 | -- PS this is solved both ways cause I've noticed the inverseness only after completion 102 | -- (you can replace additions with reverse(removals) & swaps with their inverses) 103 | 104 | -------------------------------------------------------------------------------- 105 | -- Helpers 106 | -------------------------------------------------------------------------------- 107 | 108 | swapElementsAt :: Int -> Int -> [a] -> [a] 109 | swapElementsAt i j xs = 110 | let elemI = xs !! i 111 | elemJ = xs !! j 112 | left = take i xs 113 | middle = take (j - i - 1) (drop (i + 1) xs) 114 | right = drop (j + 1) xs 115 | in left ++ [elemJ] ++ middle ++ [elemI] ++ right 116 | 117 | elemN :: Eq a => a -> [a] -> Int 118 | elemN x xs = fromJust (elemIndex x xs) 119 | 120 | incSwap :: Swapper -> Swapper 121 | incSwap (Sw (a, b)) = Sw (a+1, b+1) 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | --- 130 | -------------------------------------------------------------------------------- /src/langGenerator/Default/.gitignore: -------------------------------------------------------------------------------- 1 | Grammar.hs 2 | Tokens.hs 3 | -------------------------------------------------------------------------------- /src/langGenerator/Default/Grammar.y: -------------------------------------------------------------------------------- 1 | { 2 | module Grammar (runParse) where 3 | 4 | import Control.Monad.Except (throwError) 5 | import Tokens 6 | import PStruct 7 | } 8 | 9 | %name parseGram 10 | %tokentype { Token } 11 | %monad { Alex } 12 | %lexer { lexwrap } { Token _ TokEOF } 13 | %error { parseError } 14 | 15 | %token 16 | var { Token _ (TVar $$) } 17 | ctor { Token _ (TCtor $$) } 18 | '=' { Token _ TEq } 19 | '.' { Token _ TDot } 20 | ',' { Token _ TComma} 21 | ':' { Token _ TCol } 22 | ';' { Token _ TSemi } 23 | '(' { Token _ TLP } 24 | ')' { Token _ TRP } 25 | 26 | %% 27 | 28 | Decls : Decl { [$1] } 29 | | Decl ';' Decls { $1 : $3 } 30 | 31 | Decl : var '=' Term { Decl $1 [] $3 } 32 | | var '(' Ctx ')' '=' Term { Decl $1 $3 $6 } 33 | 34 | Term : var { VarP $1 } 35 | | ctor { Fun $1 [] } 36 | | var '(' CommaSepTms ')' { AppP $1 $3 } 37 | | ctor '(' CommaSepCtTms ')' { Fun $1 $3 } 38 | 39 | TypedVar : var ':' Term { ($1, $3) } 40 | 41 | Ctx : TypedVar { [$1] } 42 | | TypedVar ',' Ctx { $1 : $3 } 43 | 44 | CombTerm : Term { ([], $1) } 45 | | InnerTerm { $1 } 46 | 47 | InnerTerm : var '.' Term { ([$1], $3) } 48 | | '(' SpaceSepNames ')' '.' Term { ($2, $5) } 49 | 50 | CommaSepTms : Term { [$1] } 51 | | Term ',' CommaSepTms { $1 : $3 } 52 | 53 | CommaSepCtTms : CombTerm { [$1] } 54 | | CombTerm ',' CommaSepCtTms { $1 : $3 } 55 | 56 | SpaceSepNames : var { [$1] } 57 | | var SpaceSepNames { $1 : $2 } 58 | 59 | { 60 | 61 | runParse :: String -> ErrorM [Decl] 62 | runParse s = runAlex s parseGram 63 | 64 | parseError :: Token -> Alex a 65 | parseError tk = alexError ("Parse error at " ++ lcn ++ "\n") 66 | where 67 | lcn = case tk of 68 | Token _ TokEOF -> "end of file" 69 | _ -> "line " ++ show l ++ ", column " ++ show c 70 | where 71 | AlexPn _ l c = token_posn tk 72 | 73 | -- checkLevels :: TermP -> ErrorM () -- checks same level var redefs 74 | 75 | } 76 | -------------------------------------------------------------------------------- /src/langGenerator/Default/PStruct.hs: -------------------------------------------------------------------------------- 1 | module PStruct 2 | where 3 | 4 | 5 | type PError = String 6 | type Name = String 7 | type ErrorM = Either PError 8 | 9 | type CtxP = [Name] 10 | 11 | data TermP = VarP Name 12 | | Fun Name [(CtxP, TermP)] 13 | | AppP Name [TermP] 14 | deriving (Show, Eq) 15 | 16 | data Decl = Decl { 17 | nm :: Name, 18 | ctx :: [(Name, TermP)], 19 | term :: TermP 20 | } deriving (Show, Eq) 21 | 22 | 23 | --- 24 | -------------------------------------------------------------------------------- /src/langGenerator/Default/Tokens.x: -------------------------------------------------------------------------------- 1 | { 2 | module Tokens where 3 | } 4 | 5 | %wrapper "monad" 6 | 7 | $digit = 0-9 8 | $alpha = [a-zA-Z] 9 | 10 | tokens :- 11 | $white+ ; 12 | "--".* ; 13 | "=" { tok TEq } 14 | ":" { tok TCol } 15 | ";" { tok TSemi } 16 | "." { tok TDot } 17 | "," { tok TComma} 18 | "(" { tok TLP } 19 | ")" { tok TRP } 20 | [A-Z] [$alpha $digit \_ \'\-]* { tok' TCtor } 21 | [a-z] [$alpha $digit \_ \'\-]* { tok' TVar } 22 | { 23 | 24 | tok' :: (String -> Tok) -> AlexAction Token 25 | tok' f (p,_,_,s) i = return $ Token p (f (take i s)) 26 | 27 | tok :: Tok -> AlexAction Token 28 | tok = tok' . const 29 | 30 | data Tok 31 | = TEq 32 | | TCol 33 | | TSemi 34 | | TDot 35 | | TComma 36 | | TLP 37 | | TRP 38 | | TCtor String 39 | | TVar String 40 | | TokEOF 41 | deriving (Eq,Show) 42 | 43 | data Token = Token AlexPosn Tok 44 | deriving (Show) 45 | 46 | token_posn :: Token -> AlexPosn 47 | token_posn (Token p _) = p 48 | 49 | alexEOF :: Alex Token 50 | alexEOF = do 51 | (p, _, _, _) <- alexGetInput 52 | return $ Token p TokEOF 53 | 54 | lexwrap :: (Token -> Alex a) -> Alex a 55 | lexwrap = (alexMonadScan >>=) 56 | 57 | } 58 | -------------------------------------------------------------------------------- /src/langGenerator/GeneratorTemplates/LangTemplate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module LangTemplate ( 4 | TC, 5 | Ctx, 6 | consCtx, 7 | Term(..), 8 | infer, 9 | infer0, 10 | nf 11 | ) where 12 | 13 | -- Note: search is through fun name prefix matching. 14 | -- So if you switch infer and infer0 guess what happens 15 | 16 | import Prelude hiding (pi, False, True) 17 | import Data.Deriving (deriveEq1, deriveShow1) 18 | import Data.Functor.Classes 19 | import Data.Foldable 20 | import Control.Applicative 21 | import Control.Monad 22 | import Data.Functor.Identity 23 | import Control.Monad.Trans (lift) 24 | import Control.Monad.Error.Class (throwError) 25 | import Data.Traversable (fmapDefault, foldMapDefault) 26 | import Data.Traversable.Deriving 27 | import SimpleBound 28 | 29 | --- Don't make changes to the code here, may add you own functions and types 30 | --- Codegen affects infer and nf functions and Term datatype + its' Monad instance. 31 | 32 | type TC = Either String 33 | type Ctx a = a -> TC (Type a) 34 | 35 | data Term a 36 | = Var a 37 | | TyDef 38 | 39 | type Type = Term 40 | 41 | deriveEq1 ''Term 42 | deriveShow1 ''Term 43 | 44 | instance Eq a => Eq (Term a) where (==) = eq1 45 | instance Show a => Show (Term a) where showsPrec = showsPrec1 46 | 47 | instance Applicative Term where 48 | pure = Var 49 | (<*>) = ap 50 | 51 | instance Functor Term where fmap = fmapDefault 52 | instance Foldable Term where foldMap = foldMapDefault 53 | deriveTraversable ''Term 54 | 55 | instance Monad Term where 56 | Var a >>= f = f a 57 | TyDef >>= f = TyDef 58 | 59 | checkT :: (Show a, Eq a) => Ctx a -> Type a -> Term a -> TC () 60 | checkT ctx want t = do 61 | have <- infer ctx t 62 | when (nf have /= nf want) $ Left $ 63 | "type mismatch, have: " ++ (show have) ++ " want: " ++ (show want) 64 | 65 | checkEq :: (Show a, Eq a) => Term a -> Term a -> TC () 66 | checkEq want have = do 67 | when (nf have /= nf want) $ Left $ 68 | "Terms are unequal, left: " ++ (show have) ++ " right: " ++ (show want) 69 | 70 | -- checkId :: (Show a, Eq a) => Term a -> Term a -> TC () 71 | -- checkId want have = do 72 | -- when (have /= want) $ Left $ 73 | -- "Terms are unequal, left: " ++ (show have) ++ " right: " ++ (show want) 74 | 75 | 76 | report :: String -> TC (Type a) 77 | report nm = throwError $ "Can't have " ++ nm ++ " : " ++ nm 78 | 79 | emptyCtx :: (Show a, Eq a) => Ctx a 80 | emptyCtx x = Left $ "Variable not in scope: " ++ show x 81 | 82 | 83 | consCtx :: (Show a, Eq a) => Type a -> Ctx a -> Ctx (Var a) 84 | consCtx x = consCtx' x 85 | 86 | consCtx' :: (Show a, Eq a) => Type a -> Ctx a -> Ctx (Var a) 87 | consCtx' ty ctx B = pure (F <$> ty) 88 | consCtx' ty ctx (F a) = (F <$>) <$> ctx a 89 | 90 | consErr :: (Show a, Eq a) => Type a -> [Type a] -> TC (Type (Var a)) 91 | consErr t lst = throwError $ show t ++ " is not in " ++ show lst 92 | 93 | infer :: (Show a, Eq a) => Ctx a -> Term a -> TC (Type a) 94 | infer ctx (Var a) = ctx a 95 | infer ctx TyDef = throwError "Can't have def : def" 96 | 97 | -- infer in the empty context 98 | infer0 :: (Show a, Eq a) => Term a -> TC (Type a) 99 | infer0 = infer emptyCtx 100 | 101 | -- from reductions 102 | nf :: (Show a, Eq a) => Term a -> Term a 103 | nf (Var a) = Var a 104 | nf TyDef = TyDef 105 | 106 | nf':: (Show a, Eq a) => Cnt -> Term a -> Term a 107 | nf' = undefined 108 | 109 | stable :: (Show a, Eq a) => Ctx a -> Term a -> [Type a] -> TC (Type ()) 110 | stable ctx tm lst = traverse fun tm 111 | where 112 | fun x | any (\y -> ctx x == pure y) lst = pure () 113 | | otherwise = Left $ "Term is not cstable " ++ show tm 114 | 115 | rt f x = runIdentity (traverse f x) 116 | 117 | nf1 x = (toScope $ nf $ fromScope x) 118 | nf2 x = (toScope2 $ nf $ fromScope2 x) 119 | nf3 x = (toScope3 $ nf $ fromScope3 x) 120 | nf4 x = (toScope4 $ nf $ fromScope4 x) 121 | nf5 x = (toScope5 $ nf $ fromScope5 x) 122 | nf6 x = (toScope6 $ nf $ fromScope6 x) 123 | 124 | -- flatten on var (traverse rem_i x - lowers ctx by one) 125 | -- x y z. t --> x y. t 126 | rem1 :: Var a -> TC a 127 | rem1 B = Left "There is var at 1" 128 | rem1 (F x) = pure x 129 | 130 | add1 :: a -> Identity (Var a) 131 | add1 x = pure $ F x 132 | 133 | -- x y z. t --> x z. t 134 | rem2 :: Var (Var a) -> TC (Var a) 135 | rem2 B = pure B 136 | rem2 (F B) = Left "There is var at 2" 137 | rem2 (F (F x)) = pure (F x) 138 | 139 | add2 :: Var a -> Identity (Var (Var a)) 140 | add2 B = pure $ B 141 | add2 (F x) = pure $ F (F x) 142 | 143 | -- x y z. t --> y z. t 144 | rem3 :: Var (Var (Var a)) -> TC (Var (Var a)) 145 | rem3 (B ) = pure B 146 | rem3 (F (B )) = pure (F (B )) 147 | rem3 (F (F (B ))) = Left "There is var at 3" 148 | rem3 (F (F (F x))) = pure (F (F x)) 149 | 150 | add3 :: Var (Var a) -> Identity (Var (Var (Var a))) 151 | add3 (B ) = pure $ B 152 | add3 (F (B )) = pure $ F (B ) 153 | add3 (F x) = pure $ F (F x) 154 | 155 | -- r x y z. t --> x y z. t 156 | rem4 :: Var (Var (Var (Var a))) -> TC (Var (Var (Var a))) 157 | rem4 (B ) = pure (B ) 158 | rem4 (F (B )) = pure (F (B )) 159 | rem4 (F (F (B ))) = pure (F (F (B ))) 160 | rem4 (F (F (F (B )))) = Left "There is var at 4" 161 | rem4 (F (F (F (F x)))) = pure (F (F (F x))) 162 | 163 | add4 :: Var (Var (Var a)) -> Identity (Var (Var (Var (Var a)))) 164 | add4 (B ) = pure $ B 165 | add4 (F (B )) = pure $ F (B ) 166 | add4 (F (F (B ))) = pure $ F (F (B )) 167 | add4 (F x) = pure $ F (F x) 168 | 169 | ------------- Swappers 170 | swap1'2 :: Var (Var a) -> Identity (Var (Var a)) 171 | swap1'2 (B ) = pure (F (B )) 172 | swap1'2 (F (B )) = pure (B) 173 | swap1'2 x = pure x 174 | 175 | swap2'3 :: Var (Var (Var a)) -> Identity (Var (Var (Var a))) 176 | swap2'3 (B ) = pure (B ) 177 | swap2'3 (F (B )) = pure (F $ F $ B ) 178 | swap2'3 (F (F (B ))) = pure (F $ B ) 179 | swap2'3 x = pure x 180 | 181 | swap1'3 :: Var (Var (Var a)) -> Identity (Var (Var (Var a))) 182 | swap1'3 (B ) = pure (F $ F $ B ) 183 | swap1'3 (F (B )) = pure (F $ B ) 184 | swap1'3 (F (F (B ))) = pure (B ) 185 | swap1'3 x = pure x 186 | 187 | -- n free vars 188 | ap2 m f = m >>>= (lift . f) 189 | ap3 m f = ap2 m (lift . f) 190 | ap4 m f = ap3 m (lift . f) 191 | ap5 m f = ap4 m (lift . f) 192 | ap6 m f = ap5 m (lift . f) 193 | ap7 m f = ap6 m (lift . f) 194 | 195 | --------- 196 | fromScope2 x = fromScope $ fromScope x 197 | fromScope3 x = fromScope $ fromScope2 x 198 | fromScope4 x = fromScope $ fromScope3 x 199 | fromScope5 x = fromScope $ fromScope4 x 200 | fromScope6 x = fromScope $ fromScope5 x 201 | fromScope7 x = fromScope $ fromScope6 x 202 | 203 | toScope2 x = toScope $ toScope x 204 | toScope3 x = toScope $ toScope2 x 205 | toScope4 x = toScope $ toScope3 x 206 | toScope5 x = toScope $ toScope4 x 207 | toScope6 x = toScope $ toScope5 x 208 | toScope7 x = toScope $ toScope6 x 209 | 210 | 211 | data Cnt = Bot | U (Cnt) 212 | deriving(Eq, Show) 213 | 214 | --- 215 | -------------------------------------------------------------------------------- /src/langGenerator/Lang.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Lang (TC, Ctx, consCtx, Term(..), infer, infer0, nf) where 3 | import Prelude hiding (pi, False, True) 4 | import Data.Deriving (deriveEq1, deriveShow1) 5 | import Data.Functor.Classes 6 | import Data.Foldable 7 | import Control.Applicative 8 | import Control.Monad 9 | import Data.Functor.Identity 10 | import Control.Monad.Trans (lift) 11 | import Control.Monad.Error.Class (throwError) 12 | import Data.Traversable (fmapDefault, foldMapDefault) 13 | import Data.Traversable.Deriving 14 | import SimpleBound 15 | 16 | type TC = Either String 17 | 18 | type Ctx a = a -> TC (Type a) 19 | 20 | data Term a = Var a 21 | | TnDef 22 | | TyDef 23 | | App (Term a) (Term a) (Scope Type a) 24 | | Bool 25 | | False 26 | | Ff (Type a) (Term a) 27 | | Gf (Type a) (Scope (Scope Type) a) 28 | | If (Scope Type a) (Term a) (Term a) (Term a) 29 | | Lam (Type a) (Scope Term a) 30 | | Pi (Type a) (Scope Type a) 31 | | Rf (Type a) (Scope (Scope Type) a) 32 | | Sigma (Term a) (Term a) (Scope Type a) (Scope (Scope Type) a) 33 | | True 34 | 35 | type Tn = Term 36 | 37 | type Type = Term 38 | 39 | deriveEq1 ''Term 40 | 41 | deriveShow1 ''Term 42 | 43 | instance Eq a => Eq (Term a) where 44 | (==) = eq1 45 | 46 | instance Show a => Show (Term a) where 47 | showsPrec = showsPrec1 48 | 49 | instance Applicative Term where 50 | pure = Var 51 | (<*>) = ap 52 | 53 | instance Functor Term where 54 | fmap = fmapDefault 55 | 56 | instance Foldable Term where 57 | foldMap = foldMapDefault 58 | 59 | deriveTraversable ''Term 60 | 61 | instance Monad Term where 62 | Var v1 >>= f = f v1 63 | App v1 v2 v3 >>= f = App (v1 >>= f) (v2 >>= f) (v3 >>>= f) 64 | Bool >>= f = Bool 65 | False >>= f = False 66 | Ff v1 v2 >>= f = Ff (v1 >>= f) (v2 >>= f) 67 | Gf v1 v2 >>= f = Gf (v1 >>= f) (ap2 v2 f) 68 | If v1 v2 v3 v4 >>= f 69 | = If (v1 >>>= f) (v2 >>= f) (v3 >>= f) (v4 >>= f) 70 | Lam v1 v2 >>= f = Lam (v1 >>= f) (v2 >>>= f) 71 | Pi v1 v2 >>= f = Pi (v1 >>= f) (v2 >>>= f) 72 | Rf v1 v2 >>= f = Rf (v1 >>= f) (ap2 v2 f) 73 | Sigma v1 v2 v3 v4 >>= f 74 | = Sigma (v1 >>= f) (v2 >>= f) (v3 >>>= f) (ap2 v4 f) 75 | True >>= f = True 76 | TnDef >>= f = TnDef 77 | TyDef >>= f = TyDef 78 | 79 | checkT :: (Show a, Eq a) => Ctx a -> Type a -> Term a -> TC () 80 | checkT ctx want t 81 | = do have <- infer ctx t 82 | when (nf have /= nf want) $ 83 | Left $ 84 | "type mismatch, have: " ++ (show have) ++ " want: " ++ (show want) 85 | 86 | checkEq :: (Show a, Eq a) => Term a -> Term a -> TC () 87 | checkEq want have 88 | = do when (nf have /= nf want) $ 89 | Left $ 90 | "Terms are unequal, left: " ++ 91 | (show have) ++ " right: " ++ (show want) 92 | 93 | report :: String -> TC (Type a) 94 | report nm = throwError $ "Can't have " ++ nm ++ " : " ++ nm 95 | 96 | emptyCtx :: (Show a, Eq a) => Ctx a 97 | emptyCtx x = Left $ "Variable not in scope: " ++ show x 98 | 99 | consCtx :: (Show a, Eq a) => Type a -> Ctx a -> Ctx (Var a) 100 | consCtx x = consCtx' x 101 | 102 | consCtx' :: (Show a, Eq a) => Type a -> Ctx a -> Ctx (Var a) 103 | consCtx' ty ctx B = pure (F <$> ty) 104 | consCtx' ty ctx (F a) = (F <$>) <$> ctx a 105 | 106 | consErr :: 107 | (Show a, Eq a) => Type a -> [Type a] -> TC (Type (Var a)) 108 | consErr t lst = throwError $ show t ++ " is not in " ++ show lst 109 | 110 | infer :: (Show a, Eq a) => Ctx a -> Term a -> TC (Type a) 111 | infer ctx (Var v1) = ctx v1 112 | infer ctx TnDef = report "TnDef" 113 | infer ctx TyDef = report "TyDef" 114 | infer ctx al@(App v1 v2 v3) 115 | = do stable ctx al [Bool] 116 | v4 <- infer ctx v2 117 | v5 <- pure (nf v4) 118 | v6 <- infer ctx v1 119 | checkEq (Pi v5 (toScope (fromScope v3))) v6 120 | checkT ctx TyDef v5 121 | checkT (consCtx v5 ctx) TyDef (fromScope v3) 122 | infer ctx v1 123 | infer ctx v2 124 | pure (instantiate v2 (toScope (fromScope v3))) 125 | infer ctx al@Bool 126 | = do stable ctx al [Bool] 127 | pure TyDef 128 | infer ctx al@False 129 | = do stable ctx al [Bool] 130 | pure Bool 131 | infer ctx al@(Ff v1 v2) 132 | = do stable ctx al [Bool] 133 | checkT ctx TyDef v1 134 | checkT (consCtx v1 ctx) TyDef (rt add1 v1) 135 | v3 <- infer (consCtx (rt add1 v1) (consCtx v1 ctx)) 136 | (rt add1 (rt add1 v2)) 137 | v4 <- pure (nf v3) >>= traverse rem1 >>= traverse rem1 138 | v5 <- infer ctx 139 | (Gf v1 140 | (toScope2 141 | (Rf (rt add1 (rt add1 v4)) 142 | (toScope2 (rt add1 (rt add1 (rt add1 (rt add1 v4)))))))) 143 | checkEq (Rf v1 (toScope2 (rt add1 (rt add1 v4)))) v5 144 | checkT ctx TyDef v4 145 | v6 <- infer (consCtx v4 ctx) (rt add1 v2) 146 | checkEq Bool v6 147 | infer ctx v2 148 | pure TyDef 149 | infer ctx al@(Gf v1 v2) 150 | = do stable ctx al [Bool] 151 | checkT ctx TyDef v1 152 | checkT (consCtx v1 ctx) TyDef (rt add1 v1) 153 | checkT (consCtx (rt add1 v1) (consCtx v1 ctx)) TyDef 154 | (fromScope2 v2) 155 | pure (Rf v1 (toScope2 (fromScope2 v2))) 156 | infer ctx al@(If v1 v2 v3 v4) 157 | = do stable ctx al [Bool] 158 | v5 <- infer ctx v2 159 | checkEq Bool v5 160 | v6 <- infer ctx v4 161 | checkEq (instantiate False (toScope (fromScope v1))) v6 162 | v7 <- infer ctx v3 163 | checkEq (instantiate True (toScope (fromScope v1))) v7 164 | checkT ctx TyDef Bool 165 | checkT (consCtx Bool ctx) TyDef (fromScope v1) 166 | infer ctx v2 167 | infer ctx v3 168 | infer ctx v4 169 | pure (instantiate v2 (toScope (fromScope v1))) 170 | infer ctx al@(Lam v1 v2) 171 | = do stable ctx al [Bool] 172 | checkT ctx TyDef v1 173 | v3 <- infer (consCtx v1 ctx) (fromScope v2) 174 | v4 <- pure (nf v3) 175 | pure (Pi v1 (toScope v4)) 176 | infer ctx al@(Pi v1 v2) 177 | = do stable ctx al [Bool] 178 | checkT ctx TyDef v1 179 | checkT (consCtx v1 ctx) TyDef (fromScope v2) 180 | pure TyDef 181 | infer ctx al@(Rf v1 v2) 182 | = do stable ctx al [Bool] 183 | checkT ctx TyDef v1 184 | checkT (consCtx v1 ctx) TyDef (rt add1 v1) 185 | checkT (consCtx (rt add1 v1) (consCtx v1 ctx)) TyDef 186 | (fromScope2 v2) 187 | pure TyDef 188 | infer ctx al@(Sigma v1 v2 v3 v4) 189 | = do stable ctx al [Bool] 190 | checkT ctx TyDef Bool 191 | v5 <- infer (consCtx Bool ctx) (rt add1 v2) 192 | v6 <- pure (nf v5) 193 | checkEq v6 (fromScope v3) 194 | checkT ctx TyDef Bool 195 | v7 <- infer (consCtx Bool ctx) (rt add1 v1) 196 | checkEq 197 | (Pi (fromScope v3) 198 | (toScope (instantiate True (toScope (rt add2 (fromScope2 v4)))))) 199 | v7 200 | checkT ctx TyDef Bool 201 | checkT (consCtx Bool ctx) TyDef (fromScope v3) 202 | checkT (consCtx (fromScope v3) (consCtx Bool ctx)) TyDef 203 | (rt add1 (fromScope v3)) 204 | checkT 205 | (consCtx (rt add1 (fromScope v3)) 206 | (consCtx (fromScope v3) (consCtx Bool ctx))) 207 | TyDef 208 | (rt add3 (rt swap1'2 (fromScope2 v4))) 209 | infer ctx v1 210 | infer ctx v2 211 | pure 212 | (instantiate v2 213 | (toScope 214 | (instantiate (rt add1 v2) (toScope (rt swap1'2 (fromScope2 v4)))))) 215 | infer ctx al@True 216 | = do stable ctx al [Bool] 217 | pure Bool 218 | 219 | infer0 :: (Show a, Eq a) => Term a -> TC (Type a) 220 | infer0 = infer emptyCtx 221 | 222 | nf :: (Show a, Eq a) => Term a -> Term a 223 | nf (Var v1) = Var v1 224 | nf TnDef = TnDef 225 | nf TyDef = TyDef 226 | nf (App v1 v2 v3) = nf' (U Bot) (App (nf v1) (nf v2) (nf1 v3)) 227 | nf Bool = Bool 228 | nf False = False 229 | nf (Ff v1 v2) = Ff (nf v1) (nf v2) 230 | nf (Gf v1 v2) = Gf (nf v1) (nf2 v2) 231 | nf (If v1 v2 v3 v4) 232 | = nf' (U (U Bot)) (If (nf1 v1) (nf v2) (nf v3) (nf v4)) 233 | nf (Lam v1 v2) = Lam (nf v1) (nf1 v2) 234 | nf (Pi v1 v2) = Pi (nf v1) (nf1 v2) 235 | nf (Rf v1 v2) = Rf (nf v1) (nf2 v2) 236 | nf (Sigma v1 v2 v3 v4) = Sigma (nf v1) (nf v2) (nf1 v3) (nf2 v4) 237 | nf True = True 238 | 239 | nf' :: (Show a, Eq a) => Cnt -> Term a -> Term a 240 | nf' (U _) 241 | al@(App (Lam v1 (Scope (App v2 v3 (Scope v4)))) v5 (Scope v6)) 242 | = case 243 | do v7 <- pure v1 244 | v8 <- pure v6 245 | v9 <- pure v4 >>= traverse rem2 246 | v10 <- pure v5 247 | v11 <- pure v2 >>= traverse rem1 248 | v12 <- pure v3 249 | checkEq v8 v9 250 | checkEq v10 v11 251 | pure (instantiate v11 (toScope v12)) 252 | of 253 | Left _ -> nf' Bot al 254 | Right x -> nf x 255 | nf' (U (U _)) al@(If (Scope v1) True v2 v3) 256 | = case 257 | do v4 <- pure v1 258 | v5 <- pure v2 259 | v6 <- pure v3 260 | pure v5 261 | of 262 | Left _ -> nf' (U Bot) al 263 | Right x -> nf x 264 | nf' (U _) al@(If (Scope v1) False v2 v3) 265 | = case 266 | do v4 <- pure v1 267 | v5 <- pure v2 268 | v6 <- pure v3 269 | pure v6 270 | of 271 | Left _ -> nf' Bot al 272 | Right x -> nf x 273 | nf' _ x = x 274 | 275 | stable :: 276 | (Show a, Eq a) => Ctx a -> Term a -> [Type a] -> TC (Type ()) 277 | stable ctx tm lst = traverse fun tm 278 | where fun x 279 | | any (\ y -> ctx x == pure y) lst = pure () 280 | | otherwise = Left $ "Term is not cstable " ++ show tm 281 | rt f x = runIdentity (traverse f x) 282 | nf1 x = (toScope $ nf $ fromScope x) 283 | nf2 x = (toScope2 $ nf $ fromScope2 x) 284 | nf3 x = (toScope3 $ nf $ fromScope3 x) 285 | nf4 x = (toScope4 $ nf $ fromScope4 x) 286 | nf5 x = (toScope5 $ nf $ fromScope5 x) 287 | nf6 x = (toScope6 $ nf $ fromScope6 x) 288 | 289 | rem1 :: Var a -> TC a 290 | rem1 B = Left "There is var at 1" 291 | rem1 (F x) = pure x 292 | 293 | add1 :: a -> Identity (Var a) 294 | add1 x = pure $ F x 295 | 296 | rem2 :: Var (Var a) -> TC (Var a) 297 | rem2 B = pure B 298 | rem2 (F B) = Left "There is var at 2" 299 | rem2 (F (F x)) = pure (F x) 300 | 301 | add2 :: Var a -> Identity (Var (Var a)) 302 | add2 B = pure $ B 303 | add2 (F x) = pure $ F (F x) 304 | 305 | rem3 :: Var (Var (Var a)) -> TC (Var (Var a)) 306 | rem3 (B) = pure B 307 | rem3 (F (B)) = pure (F (B)) 308 | rem3 (F (F (B))) = Left "There is var at 3" 309 | rem3 (F (F (F x))) = pure (F (F x)) 310 | 311 | add3 :: Var (Var a) -> Identity (Var (Var (Var a))) 312 | add3 (B) = pure $ B 313 | add3 (F (B)) = pure $ F (B) 314 | add3 (F x) = pure $ F (F x) 315 | 316 | rem4 :: Var (Var (Var (Var a))) -> TC (Var (Var (Var a))) 317 | rem4 (B) = pure (B) 318 | rem4 (F (B)) = pure (F (B)) 319 | rem4 (F (F (B))) = pure (F (F (B))) 320 | rem4 (F (F (F (B)))) = Left "There is var at 4" 321 | rem4 (F (F (F (F x)))) = pure (F (F (F x))) 322 | 323 | add4 :: Var (Var (Var a)) -> Identity (Var (Var (Var (Var a)))) 324 | add4 (B) = pure $ B 325 | add4 (F (B)) = pure $ F (B) 326 | add4 (F (F (B))) = pure $ F (F (B)) 327 | add4 (F x) = pure $ F (F x) 328 | 329 | swap1'2 :: Var (Var a) -> Identity (Var (Var a)) 330 | swap1'2 (B) = pure (F (B)) 331 | swap1'2 (F (B)) = pure (B) 332 | swap1'2 x = pure x 333 | 334 | swap2'3 :: Var (Var (Var a)) -> Identity (Var (Var (Var a))) 335 | swap2'3 (B) = pure (B) 336 | swap2'3 (F (B)) = pure (F $ F $ B) 337 | swap2'3 (F (F (B))) = pure (F $ B) 338 | swap2'3 x = pure x 339 | 340 | swap1'3 :: Var (Var (Var a)) -> Identity (Var (Var (Var a))) 341 | swap1'3 (B) = pure (F $ F $ B) 342 | swap1'3 (F (B)) = pure (F $ B) 343 | swap1'3 (F (F (B))) = pure (B) 344 | swap1'3 x = pure x 345 | ap2 m f = m >>>= (lift . f) 346 | ap3 m f = ap2 m (lift . f) 347 | ap4 m f = ap3 m (lift . f) 348 | ap5 m f = ap4 m (lift . f) 349 | ap6 m f = ap5 m (lift . f) 350 | ap7 m f = ap6 m (lift . f) 351 | fromScope2 x = fromScope $ fromScope x 352 | fromScope3 x = fromScope $ fromScope2 x 353 | fromScope4 x = fromScope $ fromScope3 x 354 | fromScope5 x = fromScope $ fromScope4 x 355 | fromScope6 x = fromScope $ fromScope5 x 356 | fromScope7 x = fromScope $ fromScope6 x 357 | toScope2 x = toScope $ toScope x 358 | toScope3 x = toScope $ toScope2 x 359 | toScope4 x = toScope $ toScope3 x 360 | toScope5 x = toScope $ toScope4 x 361 | toScope6 x = toScope $ toScope5 x 362 | toScope7 x = toScope $ toScope6 x 363 | 364 | data Cnt = Bot 365 | | U (Cnt) 366 | deriving (Eq, Show) 367 | -------------------------------------------------------------------------------- /src/langGenerator/SimpleBound.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 2 | 3 | module SimpleBound( 4 | Scope(..), 5 | toScope, 6 | (>>>=), 7 | abstract, 8 | instantiate, 9 | Var(..) 10 | ) where 11 | 12 | import Control.Monad 13 | import Control.Monad.Trans 14 | import Control.Applicative 15 | import Data.Functor.Classes 16 | import Data.Deriving (deriveShow1) 17 | 18 | data Var a = B | F a 19 | deriving (Eq, Show) 20 | -- Fun, Fold, Trav 21 | 22 | deriveShow1 ''Var 23 | 24 | varbe :: b -> (a -> b) -> Var a -> b 25 | varbe n _ B = n 26 | varbe _ f (F x) = f x 27 | 28 | instance Eq1 Var where 29 | liftEq _ B B = True 30 | liftEq f (F a) (F b) = f a b 31 | liftEq _ _ _ = False 32 | 33 | newtype Scope f a = Scope { fromScope :: f (Var a) } 34 | -- deriving(Functor, Foldable, Traversable) 35 | 36 | toScope :: f (Var a) -> Scope f a 37 | toScope = Scope 38 | 39 | instance (Monad f, Eq1 f, Eq a) => Eq (Scope f a) where (==) = eq1 40 | instance (Show1 f, Show a) => Show (Scope f a) where showsPrec = showsPrec1 41 | 42 | instance (Monad f, Eq1 f) => Eq1 (Scope f) where 43 | liftEq f m n = liftEq (liftEq f) (fromScope m) (fromScope n) 44 | 45 | instance (Show1 f) => Show1 (Scope f) where 46 | liftShowsPrec f g d m = showsUnaryWith (liftShowsPrec f' g') "Scope" d (fromScope m) where 47 | f' = liftShowsPrec f g 48 | g' = liftShowList f g 49 | 50 | instance Monad f => Applicative (Scope f) where 51 | pure = Scope . return . F 52 | (<*>) = ap 53 | 54 | instance Monad f => Monad (Scope f) where 55 | return = Scope . return . F 56 | Scope m >>= f = Scope $ m >>= varbe (return B) (fromScope . f) 57 | 58 | instance MonadTrans Scope where 59 | lift = Scope . liftM F 60 | 61 | abstract :: (Functor f, Eq a) => a -> f a -> Scope f a 62 | abstract x xs = Scope (fmap go xs) where 63 | go y = y <$ guard (x /= y) 64 | 65 | instantiate :: Monad f => f a -> Scope f a -> f a 66 | instantiate x (Scope xs) = xs >>= go where 67 | go B = x 68 | go (F y) = return y 69 | 70 | (>>>=) :: (Monad f) => Scope f a -> (a -> f b) -> Scope f b 71 | m >>>= f = m >>= lift . f 72 | 73 | instance Applicative Var where 74 | pure = F 75 | (<*>) = ap 76 | 77 | instance Monad Var where 78 | return = pure 79 | F a >>= f = f a 80 | B >>= _ = B 81 | 82 | instance Alternative Var where 83 | empty = B 84 | B <|> r = r 85 | l <|> _ = l 86 | 87 | -------------------------------------------------- 88 | -- could be derived 89 | -------------------------------------------------------------------------------- 90 | instance Functor Var where 91 | fmap _ B = B 92 | fmap f (F a) = F (f a) 93 | 94 | instance Foldable Var where 95 | foldMap f (F a) = f a 96 | foldMap _ _ = mempty 97 | 98 | instance Traversable Var where 99 | traverse f (F a) = F <$> f a 100 | traverse _ B = pure B 101 | 102 | instance Functor f => Functor (Scope f) where 103 | fmap f (Scope a) = Scope (fmap (fmap f) a) 104 | 105 | instance Foldable f => Foldable (Scope f) where 106 | foldMap f (Scope a) = foldMap (foldMap f) a 107 | 108 | instance Traversable f => Traversable (Scope f) where 109 | traverse f (Scope a) = Scope <$> traverse (traverse f) a 110 | 111 | 112 | --- 113 | -------------------------------------------------------------------------------- /src/langGenerator/generated/DepTypedLC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ExistentialQuantification #-} 2 | 3 | -- module GenTemplate 4 | -- where 5 | 6 | import Prelude hiding (pi, False, True) 7 | import Data.Deriving (deriveEq1, deriveShow1) 8 | import Data.Functor.Classes 9 | import Control.Applicative 10 | import Control.Monad 11 | import Control.Monad.Trans 12 | import Data.Foldable 13 | import Data.Functor.Identity 14 | import Control.Monad.Error.Class (throwError) 15 | import Data.Traversable (fmapDefault, foldMapDefault) 16 | import Data.Traversable.Deriving 17 | 18 | import SimpleBound 19 | import LangTemplate (rem1, rem2, rem3, rem4, 20 | ap2, ap3, ap4, ap5, 21 | add1, add2, add3, add4, 22 | swap2'3, swap1'3, swap1'2, 23 | rt, Cnt(..), 24 | fromScope2, 25 | toScope2) 26 | 27 | type TC = Either String 28 | type Ctx a = a -> TC (Type a) 29 | 30 | consCtx :: Type a -> Ctx a -> Ctx (Var a) 31 | consCtx ty ctx (B ) = pure (F <$> ty) 32 | consCtx ty ctx (F a) = (F <$>) <$> ctx a 33 | 34 | data Term a 35 | = Varg a 36 | | TyK 37 | | True 38 | | False 39 | | Bool 40 | | Lam (Type a) (Scope Term a) 41 | | Pi (Type a) (Scope Type a) 42 | | App (Term a) (Term a) 43 | | If (Scope Type a) (Term a) (Term a) (Term a) 44 | | Bg (Scope (Scope Term) a) (Term a) 45 | 46 | type Type = Term 47 | 48 | deriveEq1 ''Term 49 | deriveShow1 ''Term 50 | 51 | instance Eq a => Eq (Term a) where (==) = eq1 52 | instance Show a => Show (Term a) where showsPrec = showsPrec1 53 | 54 | instance Applicative Term where 55 | pure = Varg 56 | (<*>) = ap 57 | 58 | instance Functor Term where fmap = fmapDefault 59 | instance Foldable Term where foldMap = foldMapDefault 60 | deriveTraversable ''Term 61 | 62 | instance Monad Term where 63 | Varg a >>= f = f a 64 | TyK >>= f = TyK 65 | Bool >>= f = Bool 66 | True >>= f = True 67 | False >>= f = False 68 | If a t x y >>= f = If (a >>>= f) (t >>= f) (x >>= f) (y >>= f) 69 | Lam ty t >>= f = Lam (ty >>= f) (t >>>= f) 70 | Pi ty t >>= f = Pi (ty >>= f) (t >>>= f) 71 | App t1 t2 >>= f = App (t1 >>= f) (t2 >>= f) 72 | Bg t1 t2 >>= f = Bg (t1 `ap2` f) (t2 >>= f) 73 | 74 | 75 | nf :: Term a -> Term a 76 | nf (Varg a) = Varg a 77 | nf TyK = TyK 78 | nf True = True 79 | nf False = False 80 | nf Bool = Bool 81 | nf (If a t x y) = nf' (U(U(Bot))) (If (toScope $ nf $ fromScope a) (nf t) (nf x) (nf y)) 82 | nf (Lam ty t) = Lam (nf ty) (toScope $ nf $ fromScope t) 83 | nf (Pi ty t) = Pi (nf ty) (toScope $ nf $ fromScope t) 84 | nf (App t1 t2) = nf' (U(Bot)) (App (nf t1) (nf t2)) 85 | 86 | nf' (U(U _)) (If a True x y) = nf x 87 | nf' (U _) (If a False x y) = nf x 88 | nf' (U _) (App (Lam ty t1) t2) = nf (instantiate t2 t1) 89 | nf' _ (Bg (Scope (Scope tm)) t) = Bg (toScope $ toScope $ nf tm) t 90 | nf' _ x = x 91 | 92 | 93 | 94 | check :: (Show a, Eq a) => Ctx a -> Type a -> Term a -> TC () 95 | check ctx want t = do 96 | have <- infer ctx t 97 | when (have /= (nf want)) $ Left $ 98 | "type mismatch, have: " ++ (show have) ++ " want: " ++ (show want) 99 | 100 | 101 | infer :: (Show a, Eq a) => Ctx a -> Term a -> TC (Type a) -- Type (Maybe (Maybe v)) x y.T -> x.T 102 | infer ctx (Varg a) = ctx a 103 | infer ctx TyK = throwError "Can't have star : star" 104 | infer ctx True = pure Bool 105 | infer ctx False = pure Bool 106 | infer ctx Bool = pure TyK 107 | infer ctx res@(If a t x y) = do 108 | stable [] res -- traverse 109 | check ctx Bool t 110 | check (consCtx Bool ctx) TyK (fromScope a) 111 | check ctx (instantiate True a) x 112 | check ctx (instantiate False a) y 113 | pure . nf $ instantiate t a 114 | infer ctx (Lam ty t) = do 115 | check ctx TyK ty 116 | Pi ty . toScope <$> infer (consCtx ty ctx) (fromScope t)--(fromScope t) 117 | infer ctx (Pi ty t) = do 118 | check ctx TyK ty 119 | check (consCtx ty ctx) TyK (fromScope t) 120 | pure TyK 121 | infer ctx a@(Bg tt t) = do 122 | cstable ctx a [piBody] 123 | (\tt -> Bg tt t) . toScope2 124 | <$> infer (consCtx (rt add1 t) $ (consCtx t ctx)) (fromScope2 tt) 125 | infer ctx (App f x) = do 126 | v <- infer ctx f 127 | case v of 128 | Pi ty t -> do 129 | check ctx ty x 130 | pure . nf $ instantiate x t 131 | _ -> Left "can't apply non-function" 132 | 133 | 134 | piBody = Lam Bool (Scope $ Varg B) 135 | 136 | cstable :: (Show a, Eq a) => Ctx a -> Term a -> [Type a] -> TC (Type ()) 137 | cstable ctx tm lst = traverse fun tm 138 | where 139 | fun x | any (\y -> ctx x == pure y) lst = pure () 140 | | otherwise = Left $ "Term is not cstable " ++ show tm 141 | 142 | emptyCtx :: Ctx a 143 | emptyCtx = (const $ Left "variable not in scope") 144 | 145 | -- infer in the empty context 146 | infer0 :: (Show a, Eq a) => Term a -> TC (Type a) 147 | infer0 = infer emptyCtx 148 | 149 | -- smart constructors 150 | lam :: Eq a => a -> Type a -> Term a -> Term a 151 | lam v ty t = Lam ty (abstract v t) 152 | 153 | pi :: Eq a => a -> Type a -> Term a -> Term a 154 | pi v ty t = Pi ty (abstract v t) 155 | 156 | iff :: Eq a => a -> Type a -> Term a -> Term a -> Term a -> Term a 157 | iff v ty t x y = If (abstract v ty) t x y 158 | 159 | 160 | fromList :: Eq a => [(a, Type a)] -> Ctx a 161 | fromList [] = emptyCtx 162 | fromList ((x,t):xs) = \y -> if (x == y) 163 | then return t 164 | else fromList xs y 165 | 166 | 167 | 168 | zer = abstract "y" (Varg "y") 169 | -- r = outBind2 $ fromScope $ abstract "y" (Varg "x") 170 | -- l = inBind2 $ fromScope $ abstract "y" (Varg "x") 171 | 172 | r' = (fromScope $ abstract "y" (Varg "x")) 173 | 174 | -- x.T -> lam(S, z.(lam(S, y.T[x:=true][v:=false]))) -- xvzy.T 175 | -- z -> z+y -> v+zy -> x+vzy 176 | -- fun :: Scope () Term a -> Term a -> Term a 177 | fun t s x v = let tm = (rt swap1'2) $ (rt add1) $ (rt add1) $ (rt add1) $ fromScope t 178 | s2 = rt add1 s 179 | tsub = (instantiate x (toScope tm)) 180 | tork = instantiate v (toScope tsub) 181 | in 182 | Lam s (toScope $ Lam s2 (toScope tork)) 183 | 184 | -- nft (Lam s t) = case (s, fromScope t) of 185 | -- (s, Lam x y) -> Lam s ( y) 186 | -- _ -> s 187 | 188 | inBool x = instantiate True x 189 | 190 | -- fals' = rta1 (rta1 (rta1 False)) 191 | -- tru' = rta1 (rta1 True) 192 | 193 | --- 194 | -------------------------------------------------------------------------------- /src/langGenerator/generated/Pars.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ExistentialQuantification #-} 2 | 3 | import Data.Foldable 4 | 5 | import SimpleBound 6 | import PStruct 7 | import Lang 8 | import Grammar 9 | 10 | 11 | 12 | convert :: TermP -> Term String 13 | convert (VarP n) = Var n 14 | convert (Fun "Pi" [([], a), ([v], b)]) = Pi (convert a) (abstract v $ convert b) 15 | convert (Fun "Lam" [([], a), ([v], b)]) = Lam (convert a) (abstract v $ convert b) 16 | convert (Fun "App" [([], a), ([], b), ([v], c)]) = App (convert a) (convert b) (abstract v $ convert c) 17 | convert (Fun "Bool" []) = Bool 18 | convert _ = error "Parse error" 19 | 20 | 21 | -- spec x = convert . term $ runParse x !! 0 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | --- 34 | -------------------------------------------------------------------------------- /src/specLang/AST.hs: -------------------------------------------------------------------------------- 1 | module AST( 2 | LangSpec(..), 3 | addStabSpec, 4 | module X 5 | ) where 6 | 7 | import AST.Term as X 8 | import AST.Judgement as X 9 | import AST.Axiom as Ax 10 | import AST.Reduction as Red 11 | 12 | -- this AST is used as output of parsing and input of typechecking 13 | -- this means there some things that are not fully correct after parsing 14 | -- like some sorts are assumed independent, but in reality they are 15 | data LangSpec = LangSpec { 16 | stabilities :: Stab 17 | , depSortNames :: [SortName] 18 | , simpleSortNames :: [SortName] 19 | , funSyms :: [FunctionalSymbol] 20 | , axioms :: [Axiom] 21 | , reductions :: [Reduction] 22 | } 23 | 24 | deStabSpec :: LangSpec -> LangSpec 25 | deStabSpec (LangSpec v2 v3 v4 v5 axes reds) = LangSpec v2 v3 v4 v5 axes' reds 26 | where axes' = (\ax -> ax{Ax.stab = deStab (Ax.stab ax)}) <$> axes 27 | -- reds' = (\r -> r{Red.stab = deStab (Red.stab r)}) <$> reds 28 | 29 | addStabSpec' :: LangSpec -> LangSpec 30 | addStabSpec' (LangSpec v2 v3 v4 v5 axes reds) = LangSpec v2 v3 v4 v5 axes' reds 31 | where axes' = (\ax -> ax{Ax.stab = addStab (Ax.stab ax) v2}) <$> axes 32 | -- reds' = (\r -> r{Red.stab = addStab (Red.stab r) v2}) <$> reds 33 | 34 | addStabSpec :: LangSpec -> LangSpec 35 | addStabSpec = addStabSpec' . deStabSpec 36 | 37 | instance Show LangSpec where 38 | show (LangSpec lst dep simp fun ax red) = concat [ 39 | "Glob stabs:\n", show lst, 40 | "Dep:\n ", showCtx id dep, "\n", 41 | "Sim:\n ", showCtx id simp, "\n", 42 | "Fun:", showCtx (helper "\n ") fun, "\n", 43 | "Ax:_______________________", 44 | showCtx (helper "\n") ax, "\n", 45 | "Red:______________________", 46 | showCtx (helper "\n") red, "\n" 47 | ] 48 | where 49 | helper :: (Show a) => String -> a -> String 50 | helper pref x = pref ++ show x 51 | 52 | 53 | 54 | 55 | -- 56 | -------------------------------------------------------------------------------- /src/specLang/AST/Axiom.hs: -------------------------------------------------------------------------------- 1 | module AST.Axiom( 2 | Axiom(..) 3 | ) where 4 | 5 | import Data.List(intercalate) 6 | 7 | import AST.Term 8 | import AST.Judgement 9 | 10 | data Axiom = Axiom { 11 | name :: Name, 12 | stab :: Stab, 13 | forallVars :: [(MetaVar, Sort)], 14 | premise :: [Judgement], 15 | conclusion :: Judgement 16 | } 17 | 18 | instance Show Axiom where 19 | show (Axiom nm st forall prem concl) = concat [ 20 | f st, 21 | nm, " =\n ", 22 | showCtx (\ (mv, s) -> show mv ++ ": " ++ show s) forall, "\n ", 23 | showCtx show prem, " |--- ", show concl, "\n"] 24 | where 25 | f Nothing = "" 26 | f (Just st') = "[" ++ intercalate "," (show <$> st') ++ "]\n" 27 | 28 | 29 | 30 | 31 | 32 | 33 | -- 34 | -------------------------------------------------------------------------------- /src/specLang/AST/Judgement.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module AST.Judgement( 4 | Judgement(..), 5 | isEqJudgement, 6 | isRedJudgement, 7 | isStatement, 8 | showCtx, 9 | jContext, 10 | judCtx, 11 | ctMetas 12 | ) where 13 | 14 | import Data.List(intercalate) 15 | import Control.Lens 16 | 17 | import AST.Term 18 | 19 | data Judgement = 20 | Statement { 21 | _jContext :: [(VarName, Term)] 22 | , jTerm :: Term 23 | , jType :: Maybe Term -- def as maybe 24 | } | 25 | Equality { 26 | _jContext :: [(VarName, Term)] 27 | , jLeft :: Term 28 | , jRight :: Term 29 | , jType :: Maybe Term -- equality t1 = t2 : Maybe t3 30 | } | 31 | Reduct { 32 | _jContext :: [(VarName, Term)] 33 | , jLeft :: Term 34 | , jRight :: Term 35 | , jType :: Maybe Term 36 | } 37 | 38 | makeLenses ''Judgement 39 | 40 | judCtx :: Judgement -> Ctx 41 | judCtx jud = jud^.jContext.to (map fst) 42 | 43 | ctMetas :: Judgement -> [MetaVar] 44 | ctMetas jud = unMeta <$> filter isMeta (jud^.jContext.to (map snd)) 45 | 46 | instance Show Judgement where 47 | show (Statement ctx tm Nothing) = concat [ 48 | showCtx showVnTm ctx, 49 | "|- ", show tm, " def"] 50 | show (Statement ctx tm (Just ty)) = concat [ 51 | showCtx showVnTm ctx, 52 | "|- ", show tm, ": ", show ty] 53 | show a@Equality{} = showEqRed a " = " 54 | show a@Reduct{} = showEqRed a " => " 55 | 56 | 57 | showCtx :: (a -> String) -> [a] -> String 58 | showCtx f lst = intercalate ", " (map f lst) 59 | 60 | showVnTm :: (VarName, Term) -> String 61 | showVnTm (a, b) = a ++ " :" ++ show b 62 | 63 | showEqRed :: Judgement -> String -> String 64 | showEqRed a@Statement{} _ = show a 65 | showEqRed a eq = case jType a of 66 | Nothing -> concat [ 67 | showCtx showVnTm (a^.jContext), 68 | "|- ", show (jLeft a), eq, show (jRight a)] 69 | Just ty -> concat [ 70 | showCtx showVnTm (a^.jContext), 71 | "|- ", show (jLeft a), eq, show (jRight a), ": ", show ty] 72 | 73 | isEqJudgement :: Judgement -> Bool 74 | isEqJudgement Equality{} = True 75 | isEqJudgement _ = False 76 | 77 | isRedJudgement :: Judgement -> Bool 78 | isRedJudgement Reduct{} = True 79 | isRedJudgement _ = False 80 | 81 | isStatement :: Judgement -> Bool 82 | isStatement Statement{} = True 83 | isStatement _ = False 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | -- 92 | -------------------------------------------------------------------------------- /src/specLang/AST/Reduction.hs: -------------------------------------------------------------------------------- 1 | module AST.Reduction( 2 | Reduction(..) 3 | ) where 4 | 5 | import Data.List(intercalate) 6 | 7 | import AST.Term 8 | import AST.Judgement 9 | 10 | data Reduction = Reduction { 11 | name :: Name, 12 | stab :: Stab, 13 | forallVars :: [(MetaVar, Sort)], 14 | premise :: [Judgement], 15 | conclusion :: Judgement 16 | } 17 | 18 | instance Show Reduction where 19 | show (Reduction nm st forall prem concl) = concat [ 20 | f st, 21 | nm, " =\n ", 22 | showCtx (\ (mv, s) -> show mv ++ ": " ++ show s) forall, "\n ", 23 | showCtx show prem, " |--- ", show concl, "\n"] 24 | where 25 | f Nothing = "" 26 | f (Just st') = "[" ++ intercalate "," (show <$> st') ++ "]\n" 27 | 28 | 29 | 30 | 31 | 32 | -- 33 | -------------------------------------------------------------------------------- /src/specLang/AST/Term.hs: -------------------------------------------------------------------------------- 1 | module AST.Term( 2 | SortName(..), 3 | VarName(..), 4 | Name(..), 5 | ContextDepth(..), 6 | DefaultErr(..), 7 | Sort(..), 8 | Ctx(..), 9 | FunctionalSymbol(..), 10 | MetaVar(..), 11 | Term(..), 12 | isMeta, 13 | unMeta, 14 | varSort, 15 | tyName, 16 | tmName, 17 | getSortName, 18 | getSortDepth, 19 | addToCtx, 20 | lowerCtx, 21 | zero, 22 | isDepSort, 23 | lookupName, 24 | lookupName', 25 | isFunSym, 26 | isVar, 27 | identicalMV, 28 | allUnique, 29 | isSubset, 30 | toListM, 31 | changeError, 32 | Stab, 33 | deStab, 34 | addStab 35 | ) where 36 | 37 | import qualified Data.Set as Set 38 | import Data.List(intercalate, sort) 39 | 40 | type SortName = String 41 | type VarName = String 42 | type Name = String 43 | type ContextDepth = Int 44 | type DefaultErr = Either String 45 | 46 | -- Nothing - means stable 47 | -- else stable only for x in (Just x) 48 | type Stab = Maybe [Term] 49 | 50 | changeError :: String -> DefaultErr a -> DefaultErr a 51 | changeError msg (Left x) = Left (msg ++ "\n\t" ++ x) 52 | changeError _ x = x 53 | 54 | data Sort = DepSort SortName !ContextDepth | SimpleSort SortName 55 | deriving (Eq) 56 | 57 | type Ctx = [VarName] 58 | 59 | bracket :: String -> String 60 | bracket s = "(" ++ s ++ ")" 61 | 62 | instance Show Sort where 63 | show (DepSort nm dp) = bracket $ nm ++ "," ++ show dp 64 | show (SimpleSort nm) = nm 65 | 66 | varSort :: Sort 67 | varSort = DepSort tmName 0 68 | 69 | tyName :: SortName 70 | tyName = "ty" 71 | 72 | tmName :: SortName 73 | tmName = "tm" 74 | 75 | getSortName :: Sort -> SortName 76 | getSortName (DepSort nm _) = nm 77 | getSortName (SimpleSort nm) = nm 78 | 79 | getSortDepth :: Sort -> ContextDepth 80 | getSortDepth (SimpleSort _) = 0 81 | getSortDepth (DepSort _ x) = x 82 | 83 | zero :: Sort -> Sort 84 | zero (DepSort nm _) = DepSort nm 0 85 | zero x = x 86 | 87 | addToCtx :: ContextDepth -> Sort -> DefaultErr Sort 88 | addToCtx _ (SimpleSort _) = Left "Simple sorts can't have context" 89 | addToCtx n (DepSort nm num) | num + n >= 0 = return (DepSort nm $ num + n) 90 | | otherwise = Left "Context is empty already" 91 | 92 | lowerCtx :: Sort -> DefaultErr Sort 93 | lowerCtx = addToCtx (-1) 94 | 95 | isDepSort :: Sort -> Bool 96 | isDepSort (DepSort _ _) = True 97 | isDepSort _ = False 98 | 99 | data FunctionalSymbol = FunSym { 100 | name :: Name 101 | , arguments :: [Sort] 102 | , result :: Sort --- hack in the parser that gets solved in the checking stage 103 | } deriving (Eq) 104 | 105 | instance Show FunctionalSymbol where 106 | show (FunSym nm [] res) = nm ++ ": " ++ show res 107 | show (FunSym nm args res) = 108 | nm ++ ": " ++ intercalate "*" (map show args) ++ "->" ++ show res 109 | 110 | data MetaVar = MetaVar { 111 | mContext :: [VarName] 112 | , mName :: VarName 113 | } 114 | 115 | instance Eq MetaVar where 116 | m == m' = (mName m) == (mName m') 117 | 118 | identicalMV :: MetaVar -> MetaVar -> Bool 119 | identicalMV (MetaVar ct1 vn1) (MetaVar ct2 vn2) = (sort ct1) == (sort ct2) && vn1 == vn2 120 | 121 | instance Ord MetaVar where 122 | m `compare` m' = (mName m) `compare` (mName m') 123 | 124 | 125 | showCtxVar :: [Name] -> String -> String 126 | showCtxVar [] y = y 127 | showCtxVar [x] y = x ++ "." ++ y 128 | showCtxVar args y = bracket (unwords args) ++ "." ++ y 129 | 130 | instance Show MetaVar where 131 | show (MetaVar x y) = showCtxVar x y 132 | 133 | data Term = Var VarName -- xyz 134 | | Meta MetaVar 135 | | FunApp Name [(Ctx, Term)] 136 | | Subst Term VarName Term 137 | deriving (Eq) 138 | 139 | toListM :: Term -> [MetaVar] 140 | toListM (Var _) = [] 141 | toListM (Meta mv) = [mv] 142 | toListM (Subst tm1 _ tm2) = toListM tm1 ++ toListM tm2 143 | toListM (FunApp _ lst) = concat (toListM . snd <$> lst) 144 | 145 | isMeta :: Term -> Bool 146 | isMeta (Meta _) = True 147 | isMeta _ = False 148 | 149 | unMeta :: Term -> MetaVar 150 | unMeta (Meta mv) = mv 151 | 152 | instance Show Term where 153 | show (Var nm) = nm 154 | show (Meta vr) = mName vr ++ "-m" 155 | show (FunApp nm []) = nm ++ "-f" 156 | show (FunApp nm args) = nm ++ bracket (intercalate ", " (map (\(x, y) -> showCtxVar x (show y)) args)) 157 | show (Subst into vn what) = show into ++ "[" ++ vn ++ ":= " ++ show what ++ "]" 158 | 159 | isFunSym :: Term -> Bool 160 | isFunSym FunApp{} = True 161 | isFunSym _ = False 162 | 163 | isVar :: Term -> Bool 164 | isVar Var{} = True 165 | isVar _ = False 166 | 167 | lookupName :: (a -> Name) -> Name -> [a] -> DefaultErr a 168 | lookupName f = lookupName' (\x y -> f x == y) 169 | 170 | -- f : tm + name = equal? 171 | lookupName' :: (a -> Name -> Bool) -> Name -> [a] -> DefaultErr a 172 | lookupName' idf name (x : xs) | idf x name = return x 173 | | otherwise = lookupName' idf name xs 174 | lookupName' _ name _ = Left $ "Name " ++ show name ++ " not found!" 175 | 176 | allUnique :: Ord a => [a] -> Bool 177 | allUnique a = length a == Set.size (Set.fromList a) 178 | 179 | isSubset :: Ord a => [a] -> [a] -> Bool 180 | isSubset a b = 0 == Set.size (Set.difference (Set.fromList a) (Set.fromList b)) 181 | 182 | deStab :: Stab -> Stab 183 | deStab Nothing = Just [] 184 | deStab x = x 185 | 186 | addStab :: Stab -> Stab -> Stab 187 | addStab x Nothing = x 188 | addStab Nothing x = x 189 | addStab (Just x) (Just y) = Just (x ++ y) 190 | 191 | -- 192 | -------------------------------------------------------------------------------- /src/specLang/SortCheck.hs: -------------------------------------------------------------------------------- 1 | module SortCheck ( 2 | module X, 3 | sortCheck, 4 | runSortCheck, 5 | mainCheck, 6 | sortCheckIO 7 | ) where 8 | 9 | import Control.Monad.Trans.State.Lazy 10 | import Control.Lens 11 | 12 | import AST 13 | import SortCheck.SymbolTable as X 14 | import SortCheck.Sort 15 | import SortCheck.FunSym 16 | import SortCheck.Axiom 17 | import SortCheck.Reduction 18 | import SortCheck.Term (checkStab) 19 | 20 | import Parser (parseLang) 21 | 22 | sortCheck :: LangSpec -> SortCheckM () 23 | sortCheck lsp = do 24 | sortCheckSorts lsp 25 | sortCheckFunSyms (AST.funSyms lsp) 26 | stabs <~ checkStab (AST.stabilities lsp) 27 | sortCheckAxioms (AST.axioms lsp) 28 | sortCheckReductions (AST.reductions lsp) 29 | 30 | runSortCheck :: Either String LangSpec -> Either SortError SymbolTable 31 | runSortCheck langSp = do 32 | lsp' <- langSp 33 | execStateT (sortCheck lsp') varsInit 34 | 35 | -------------------------------------------------------------------------------- 36 | -- Main 37 | 38 | mainCheck :: FilePath -> IO () 39 | mainCheck file = do 40 | st <- sortCheckIO file 41 | putStrLn $ case st of 42 | Left err -> "hmm " ++ err 43 | Right x -> show x 44 | 45 | sortCheckIO :: FilePath -> IO (Either SortError SymbolTable) 46 | sortCheckIO file = do 47 | str <- readFile file 48 | let lang = parseLang file str 49 | return $ runSortCheck lang 50 | 51 | 52 | 53 | --- 54 | -------------------------------------------------------------------------------- /src/specLang/SortCheck/AxCtxVars.hs: -------------------------------------------------------------------------------- 1 | module SortCheck.AxCtxVars ( 2 | checkCtxVars 3 | ) where 4 | 5 | import Control.Monad.Trans.State.Lazy 6 | import Control.Monad.Except (throwError) 7 | import Control.Monad.Trans.Class (lift) 8 | import Control.Lens 9 | import Data.Maybe (isJust) 10 | import Control.Monad (when, unless) 11 | 12 | import qualified Data.Map as Map 13 | 14 | import AST 15 | import AST.Axiom as Axiom 16 | import SortCheck.SymbolTable as SymbolTable 17 | import SortCheck.Term(checkStab) 18 | import SortCheck.Judgement 19 | import SortCheck.Forall 20 | 21 | -------------------------------------------------------------------------------- 22 | 23 | -- We have f(B, x.A, yz.S) + [y:0, z:1], [x:0] 24 | -- |- z : S -- all vars are to the left of S, can have cycles. say x:R |- t1:S, y:S |- t2:R 25 | -- forall z.B, z.T -- z : A |- B : T -- check z uses only leftmost guys 26 | -- same with |- lam(t, x.(lam tm, y.k)) -- y : tm -- all metas here are to the left of y.k 27 | 28 | checkCtxVars :: [MetaVar] -> Axiom -> SortCheckM () 29 | checkCtxVars mvs juds = do 30 | -- let ct = jud^.jContext 31 | return () 32 | -- mvs' <- expandWithTys mvs prems 33 | 34 | --- 35 | -------------------------------------------------------------------------------- /src/specLang/SortCheck/Axiom.hs: -------------------------------------------------------------------------------- 1 | module SortCheck.Axiom ( 2 | sortCheckAxioms 3 | ) 4 | where 5 | 6 | import Control.Monad.Trans.State.Lazy 7 | import Control.Monad.Except (throwError) 8 | import Control.Monad.Trans.Class (lift) 9 | import Control.Lens 10 | import Data.Maybe (isJust) 11 | import Control.Monad (when, unless) 12 | 13 | import qualified Data.Map as Map 14 | 15 | import AST 16 | import AST.Axiom as Axiom 17 | import SortCheck.SymbolTable as SymbolTable 18 | import SortCheck.Term(checkStab) 19 | import SortCheck.Judgement 20 | import SortCheck.Forall 21 | import SortCheck.AxCtxVars (checkCtxVars) 22 | 23 | -------------------------------------------------------------------------------- 24 | -- Axioms 25 | 26 | sortCheckAxioms :: [Axiom] -> SortCheckM () 27 | sortCheckAxioms axs = do 28 | sortCheckAxioms' axs 29 | st <- get 30 | when (Map.size (st^.iSymAxiomMap) < Map.size (st^.SymbolTable.funSyms)) $ 31 | throwError "Not all funSyms have intro axioms" 32 | 33 | sortCheckAxioms' :: [Axiom] -> SortCheckM () 34 | sortCheckAxioms' [] = return () 35 | sortCheckAxioms' (ax : axs) = do 36 | ax' <- checkAx ax 37 | modify $ over SymbolTable.axioms (Map.insert (Axiom.name ax') ax') 38 | 39 | -- check there is only one funSym intro axiom 40 | -- can't have equalities in the conclusion 41 | funSym <- getAxFunSym ax' 42 | st <- get 43 | when (isJust $ Map.lookup funSym (st^.iSymAxiomMap)) $ 44 | throwError $ "There is already an intro axiom for " ++ funSym 45 | modify $ over iSymAxiomMap (Map.insert funSym (Axiom.name ax')) 46 | sortCheckAxioms' axs 47 | 48 | -- statements are always funSym intros 49 | -- we're here strictly after simple checking of terms => have all the funsyms we need 50 | getAxFunSym :: Axiom -> SortCheckM Name 51 | getAxFunSym ax@(Axiom nm _ fvs prems (Statement _ (FunApp name tms) ty)) = do 52 | mvs <- checkArgsAreMetaVars (map fst fvs) tms 53 | ------------------------------------- 54 | (FunSym _ _ srt) <- uses (SymbolTable.funSyms) (unJust . Map.lookup name) 55 | when (null ty && srt == varSort) $ 56 | throwError $ "Axiom that introduces a funsym of sort tm must have a type: " ++ nm 57 | ------------------------------------- 58 | -- checks that vars use correct metas only 59 | checkCtxVars mvs ax 60 | ------------------------------------- 61 | -- checks that we have all depmetas premises 62 | mapM_ (checkHavePrems nm prems) mvs 63 | return name 64 | where 65 | checkArgsAreMetaVars :: [MetaVar] -> [(Ctx, Term)] -> SortCheckM [MetaVar] 66 | checkArgsAreMetaVars fvs [] = return [] 67 | checkArgsAreMetaVars fvs ((ct, Meta ma@(MetaVar _ mvN)): xs) = do 68 | let mv = MetaVar ct mvN 69 | let fv = unJust $ lookup mv (zip fvs fvs) 70 | unless (identicalMV mv fv) $ 71 | throwError $ show mv ++ " has different context from " ++ 72 | show fv ++ " in funsym intro axiom: " ++ nm 73 | mvs <- checkArgsAreMetaVars fvs xs 74 | return (ma:mvs) 75 | checkArgsAreMetaVars _ _ = throwError $ "Not all terms in " ++ name ++ 76 | " are metavars in: " ++ nm 77 | getAxFunSym (Axiom _ _ _ _ Statement {}) = 78 | throwError "Implementation bug, should have FunApp here" 79 | getAxFunSym _ = throwError "Implementation bug, cannot have equality judgement in conclusion" 80 | 81 | -- need to check forall var types and change them if need be 82 | -- check redefinition, fix forallvars, check types inside each judgement 83 | checkAx :: Axiom -> SortCheckM Axiom 84 | checkAx ax@(Axiom name stabs forall prem concl) = do 85 | st <- get 86 | 87 | when (Map.member name $ st^.SymbolTable.axioms) $ 88 | throwError $ "Axiom redefinition: " ++ name 89 | 90 | when (isEqJudgement concl) $ 91 | throwError $ "Equality is not allowed in the conclusion of typing rules: " ++ name ++ "\nUse reductions" 92 | 93 | unless (null $ _jContext concl) $ 94 | throwError $ "Conclusion must have empty context: " ++ name 95 | 96 | stab' <- checkStab stabs 97 | forall' <- checkForallVars forall 98 | prem' <- mapM (checkJudgem forall') prem 99 | concl' <- checkJudgem forall' concl 100 | 101 | return (Axiom name stab' forall' prem' concl') 102 | 103 | checkHavePrems :: String -> [Judgement] -> MetaVar -> SortCheckM () 104 | checkHavePrems _ prems (MetaVar [] _) = return () 105 | checkHavePrems nm prems mv = 106 | unless (any (metaPrem mv) prems) $ 107 | throwError $ show mv ++ " doesn't have a premise Judgement! In axiom: " ++ nm 108 | 109 | where 110 | metaPrem :: MetaVar -> Judgement -> Bool 111 | metaPrem mv (Statement _ tm Nothing) = tm == (Meta mv) 112 | metaPrem mv (Statement _ tm (Just ty)) = tm == (Meta mv) || (Meta mv) == ty 113 | metaPrem _ _ = False 114 | 115 | --- 116 | -------------------------------------------------------------------------------- /src/specLang/SortCheck/Forall.hs: -------------------------------------------------------------------------------- 1 | module SortCheck.Forall ( 2 | MetaCtx(..), 3 | checkForallVars 4 | ) where 5 | 6 | import Control.Monad.Trans.State.Lazy 7 | import Control.Monad.Except (throwError) 8 | import Control.Monad.Trans.Class (lift) 9 | import Control.Lens 10 | import Data.Maybe (isJust) 11 | import Control.Monad (when, unless) 12 | 13 | import qualified Data.Set as Set 14 | 15 | import AST 16 | import SortCheck.SymbolTable as SymbolTable 17 | 18 | type MetaCtx = [(MetaVar, Sort)] 19 | 20 | -------------------------------------------------------------------------------- 21 | -- ForallVars 22 | 23 | -- This function looks up a sortName in state 24 | -- ContextDepth is needed for forming the sort (not lookup) 25 | checkSortByName :: ContextDepth -> SortName -> SortCheckM Sort 26 | checkSortByName depth name = do 27 | st <- get 28 | if Set.member name (st^.simpleSorts) 29 | then 30 | if depth == 0 31 | then return (SimpleSort name) 32 | else throwError $ "Independent sort " ++ name ++ " can't have non-empty context" 33 | else 34 | if Set.member name (st^.depSorts) 35 | then return (DepSort name depth) 36 | else 37 | throwError $ "Sort " ++ name ++ " is not defined" 38 | 39 | -- checks and modifies one vars and checks for dups 40 | checkForallVars :: MetaCtx -> SortCheckM MetaCtx 41 | checkForallVars forall = do 42 | -- changes the sort to appropriate depth (if it's dependent at all) 43 | forall' <- mapM (\ (a , b) -> do 44 | b' <- checkSortByName (length $ mContext a) (getSortName b) 45 | return (a , b') ) forall 46 | -- check for dups in captures and x.x situations 47 | mapM_ (\ (a , _) -> unless (allUnique (mName a : mContext a)) $ 48 | throwError "Duplicates in captures") forall' 49 | unless (allUnique $ map (mName . fst) forall') $ 50 | throwError "Duplicates in metas" 51 | 52 | return forall' 53 | 54 | 55 | 56 | 57 | --- 58 | -------------------------------------------------------------------------------- /src/specLang/SortCheck/FunSym.hs: -------------------------------------------------------------------------------- 1 | module SortCheck.FunSym( 2 | sortCheckFunSyms 3 | ) where 4 | 5 | import Control.Monad.Trans.State.Lazy 6 | import Control.Monad.Except (throwError) 7 | import Control.Lens 8 | import Data.Maybe (isJust) 9 | import Control.Monad (when, unless) 10 | 11 | import qualified Data.Map as Map 12 | import qualified Data.Set as Set 13 | 14 | import AST 15 | import SortCheck.SymbolTable as SymbolTable 16 | 17 | -------------------------------------------------------------------------------- 18 | -- FunSyms 19 | 20 | -- SortCheck and populate the state with funsyms 21 | -- (sorts of func return types may need modification - we do it here) 22 | sortCheckFunSyms :: [FunctionalSymbol] -> SortCheckM () 23 | sortCheckFunSyms [] = return () 24 | sortCheckFunSyms (fs : fss) = do 25 | fs' <- checkFun fs 26 | modify $ over SymbolTable.funSyms (Map.insert (name fs') fs') 27 | sortCheckFunSyms fss 28 | 29 | -- Checks func redefinition, checks depsorts and simplesorts 30 | -- Adds the return sort 31 | checkFun :: FunctionalSymbol -> SortCheckM FunctionalSymbol 32 | checkFun fs@(FunSym name args res) = do 33 | st <- get 34 | 35 | when (isJust $ Map.lookup name (st^.SymbolTable.funSyms)) $ 36 | throwError $ "Function redefinition " ++ name 37 | 38 | -- Adding the type knowledge of the result here 39 | let fs' = if Set.member (getSortName res) (st^.simpleSorts) 40 | then fs 41 | else FunSym name args (DepSort (getSortName res) 0) 42 | 43 | -- filters args by f, checks if they are all in the set 44 | let isIn f set = Set.size (Set.difference (Set.fromList (map getSortName (filter f args))) set) == 0 45 | 46 | unless (isIn isDepSort (st^.depSorts)) $ 47 | throwError $ show name ++ " functional symbol's dependent sorts are not completely defined" 48 | unless (isIn (not . isDepSort) (st^.simpleSorts)) $ 49 | throwError $ show name ++ " functional symbol's simple sorts are not completely defined" 50 | 51 | return fs' 52 | 53 | 54 | 55 | 56 | --- 57 | -------------------------------------------------------------------------------- /src/specLang/SortCheck/Judgement.hs: -------------------------------------------------------------------------------- 1 | module SortCheck.Judgement ( 2 | checkJudgem 3 | ) where 4 | 5 | -- import Control.Monad.Trans.State.Lazy 6 | import Control.Monad.Except (throwError) 7 | import Control.Monad.Trans.Class (lift) 8 | import Control.Monad (when, unless) 9 | import Control.Lens 10 | 11 | import qualified Data.Set as Set 12 | 13 | import AST 14 | 15 | import SortCheck.SymbolTable as SymbolTable 16 | import SortCheck.Forall (MetaCtx) 17 | import SortCheck.Term 18 | import SortCheck.Sort 19 | 20 | -------------------------------------------------------------------------------- 21 | -- Judgements 22 | type TypedCtx = [(VarName, Term)] 23 | 24 | -- given meta vars (forall) and a judgement - SortChecks it 25 | -- first checks context 26 | -- !!!then does all the different judgement specific ops 27 | checkJudgem :: MetaCtx -> Judgement -> SortCheckM Judgement 28 | checkJudgem meta jud = do 29 | let ctx = _jContext jud 30 | (vctx, ctx') <- checkCtx meta ctx 31 | checkJSpecific meta vctx (jContext .~ ctx' $ jud) 32 | 33 | -- Specific stuff for judgements 34 | -- Statement - check "tm : ty" 35 | -- Equality & reduction - check sorts are same in = & => 36 | -- Reduction - check right has subset of metas & left starts with funsym 37 | checkJSpecific :: MetaCtx -> Ctx -> Judgement -> SortCheckM Judgement 38 | checkJSpecific meta ctx (Statement ctxx tm (Just ty)) = do 39 | (tm', tmSort) <- checkTerm meta ctx tm 40 | (ty', tySort) <- checkTerm meta ctx ty 41 | checkTmSort tmSort tm' 42 | checkTySort tySort ty' 43 | return (Statement ctxx tm' (Just ty')) 44 | checkJSpecific meta ctx (Statement ctxx tm Nothing) = do 45 | (tm', _) <- checkTerm meta ctx tm 46 | return (Statement ctxx tm' Nothing) 47 | checkJSpecific meta ctx ax@Equality{} = checkEqAndRed meta ctx ax 48 | -- left starts from funsym 49 | checkJSpecific meta ctx red@(Reduct _ l@FunApp{} r ty) = do 50 | -- reduct specific stuff: 51 | -- all metas right in left 52 | unless (getMetas r `Set.isSubsetOf` getMetas l) $ throwError $ 53 | "Metas to the right of reduction should be present on the left" ++ show red 54 | checkEqAndRed meta ctx red 55 | where 56 | getMetas :: Term -> Set.Set SortName 57 | getMetas = getMetas' Set.empty 58 | where 59 | getMetas' st (Meta v) = Set.insert (mName v) st 60 | getMetas' st (Var _) = st 61 | getMetas' st (Subst to _ what) = Set.union (getMetas' st to) (getMetas' st what) 62 | getMetas' st (FunApp _ lst) = foldr ((Set.union . getMetas' st) . snd) Set.empty lst 63 | 64 | checkJSpecific _ _ red = throwError $ "Reducts should start from a funSym " ++ show red 65 | 66 | 67 | checkEqAndRed :: MetaCtx -> Ctx -> Judgement -> SortCheckM Judgement 68 | checkEqAndRed meta ctx judg = do 69 | (ltm, lSort) <- checkTerm meta ctx (jLeft judg) 70 | (rtm, rSort) <- checkTerm meta ctx (jRight judg) 71 | checkEqSorts (getSortName lSort) (getSortName rSort) $ 72 | "Sorts are unequal in" ++ show judg 73 | case jType judg of 74 | Nothing -> return $ retNewJ judg ltm rtm Nothing 75 | Just ty -> do 76 | checkTmSort lSort (jLeft judg) 77 | (tytm, tySort) <- checkTerm meta ctx ty 78 | checkTySort tySort ty 79 | return $ retNewJ judg ltm rtm (Just tytm) 80 | where 81 | retNewJ :: Judgement -> Term -> Term -> Maybe Term -> Judgement 82 | retNewJ (Equality ctx _ _ _) l r t = Equality ctx l r t 83 | retNewJ (Reduct ctx _ _ _) l r t = Reduct ctx l r t 84 | retNewJ _ _ _ _ = error "retNewJ is in error" 85 | 86 | -------------------------------------------------------------------- 87 | -- Adds vars to Ctx as it checks 88 | -- Also fixes ctx terms 89 | checkCtx :: MetaCtx -> TypedCtx -> SortCheckM (Ctx, TypedCtx) 90 | checkCtx mCtx = checkCtxVarsHelper mCtx [] [] 91 | where 92 | checkCtxVarsHelper :: MetaCtx -> Ctx -> TypedCtx -> TypedCtx -> SortCheckM (Ctx, TypedCtx) 93 | checkCtxVarsHelper _ ctx tctx [] = return (ctx, reverse tctx) 94 | checkCtxVarsHelper mCtx ctx tctx ((vname, tm):xs) = do 95 | (tm', tySort) <- checkTerm mCtx ctx tm 96 | checkTySort tySort tm' 97 | let tctx' = (vname, tm') : tctx 98 | 99 | -- check if it's in metas we have it fixed 100 | -- !!(this is here and not just 101 | -- case on "checkTerm mCtx ctx (Var vname)" -- same lookup is inside there! 102 | -- cause I forgot how destructure it) 103 | case lookupName (AST.mName . fst) vname mCtx of 104 | Right _ -> do 105 | (tm'', srt) <- checkTerm mCtx ctx (Var vname) 106 | checkTmSort srt tm'' 107 | checkCtxVarsHelper mCtx ctx tctx' xs 108 | -- ELSE it's a variable 109 | Left _ -> do 110 | ctx' <- checkCtxShadowing ctx [vname] 111 | checkCtxVarsHelper mCtx ctx' tctx' xs 112 | 113 | 114 | 115 | 116 | 117 | 118 | --- 119 | -------------------------------------------------------------------------------- /src/specLang/SortCheck/Reduction.hs: -------------------------------------------------------------------------------- 1 | module SortCheck.Reduction ( 2 | sortCheckReductions 3 | ) where 4 | 5 | import Control.Monad.Trans.State.Lazy 6 | import Control.Monad.Except (throwError) 7 | import Control.Monad.Trans.Class (lift) 8 | import Control.Lens 9 | import Data.Maybe (isJust) 10 | import Control.Monad (when, unless) 11 | 12 | import qualified Data.Map as Map 13 | 14 | import AST 15 | import AST.Reduction as Reduction 16 | import SortCheck.SymbolTable as SymbolTable 17 | import SortCheck.Forall 18 | import SortCheck.Term(checkStab) 19 | import SortCheck.Judgement 20 | 21 | -------------------------------------------------------------------------------- 22 | -- Reductions 23 | 24 | sortCheckReductions :: [Reduction] -> SortCheckM () 25 | sortCheckReductions [] = return () 26 | sortCheckReductions (red : reds) = do 27 | red' <- checkRed red 28 | modify $ over SymbolTable.reductions (Map.insert (Reduction.name red') red') 29 | 30 | checkConclRed (conclusion red') 31 | sortCheckReductions reds 32 | 33 | checkRed :: Reduction -> SortCheckM Reduction 34 | checkRed red@(Reduction name stabs forall prem concl) = do 35 | st <- get 36 | 37 | when (isJust $ Map.lookup name (st^.SymbolTable.reductions)) $ 38 | throwError $ "Reduction redefinition: " ++ name 39 | 40 | unless (isRedJudgement concl) $ 41 | throwError $ "Must be a reduction: " ++ name 42 | 43 | stab' <- checkStab stabs 44 | forall' <- checkForallVars forall 45 | prem' <- mapM (checkJudgem forall') prem 46 | concl' <- checkJudgem forall' concl 47 | 48 | return (Reduction name stab' forall' prem' concl') 49 | 50 | checkConclRed :: Judgement -> SortCheckM () 51 | checkConclRed r@(Reduct _ lft rt _) = do 52 | noSubstLeft ("Subst on the left of reduction " ++ show r) lft 53 | unless (isSubset (toListM rt) (toListM lft)) $ 54 | throwError $ "Not all metavars on right of " ++ show r ++ " are on the left" 55 | checkConclRed _ = throwError $ "Reduction must be a reduct, impl error" 56 | 57 | noSubstLeft :: String -> Term -> SortCheckM () 58 | noSubstLeft msg (Subst{}) = throwError msg 59 | noSubstLeft msg (FunApp _ lst) = mapM_ (noSubstLeft msg . snd) lst 60 | noSubstLeft _ _ = return () 61 | 62 | 63 | --- 64 | -------------------------------------------------------------------------------- /src/specLang/SortCheck/Sort.hs: -------------------------------------------------------------------------------- 1 | module SortCheck.Sort( 2 | sortCheckSorts, 3 | checkTmSort, 4 | checkTySort, 5 | checkEqSorts 6 | ) where 7 | 8 | import Control.Monad.Trans.State.Lazy 9 | import Control.Monad.Except (throwError) 10 | import Control.Monad.Trans.Class (lift) 11 | import Control.Lens 12 | import Control.Monad (when, unless) 13 | 14 | import qualified Data.Set as Set 15 | 16 | import AST 17 | import SortCheck.SymbolTable as SymbolTable 18 | 19 | -------------------------------------------------------------------------------- 20 | -- Sorts 21 | 22 | -- SortName or VarName 23 | -- Throws Error when there are duplicatese in a list of names 24 | checkForDups :: String -> [Name] -> Either SortError (Set.Set Name) 25 | checkForDups msg lst = do 26 | let deps = Set.fromList lst 27 | when (length lst /= Set.size deps) $ throwError msg 28 | return deps 29 | 30 | -- Checks for duplicates, intersections and sets the sorts 31 | sortCheckSorts :: LangSpec -> SortCheckM () 32 | sortCheckSorts lsp = do 33 | deps <- lift . checkForDups "Duplicates in sorts" $ AST.depSortNames lsp 34 | sims <- lift . checkForDups "Duplicates in sorts" $ AST.simpleSortNames lsp 35 | when (Set.size (Set.intersection sims deps) /= 0) $ throwError "Dependent and simple sorts can't intersect" 36 | unless (Set.member tmName deps) $ throwError $ "Need to have a " ++ tmName ++ " sort" 37 | unless (Set.member tyName deps || Set.member tyName sims) $ 38 | throwError $ "Need to have a " ++ tyName ++ " sort" 39 | modify $ set depSorts deps 40 | modify $ set simpleSorts sims 41 | 42 | -------------------------------------------------------------------- 43 | -- given a sort checks if it's equal to universal tm sort 44 | checkTmSort :: Sort -> Term -> SortCheckM () 45 | checkTmSort tmSort tm = 46 | let sName = getSortName tmSort in 47 | checkEqSorts sName tmName $ "Left of : is not a term, but " ++ show sName ++ 48 | "\n in " ++ show tm 49 | 50 | checkTySort :: Sort -> Term -> SortCheckM () 51 | checkTySort tySort tm = 52 | let sName = getSortName tySort in 53 | checkEqSorts sName tyName $ "Right of : is not a type, but " ++ show sName ++ 54 | "\n in " ++ show tm 55 | 56 | checkEqSorts :: SortName -> SortName -> String -> SortCheckM () 57 | checkEqSorts l r msg = when (l /= r) $ throwError msg 58 | 59 | --- 60 | -------------------------------------------------------------------------------- /src/specLang/SortCheck/SymbolTable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module SortCheck.SymbolTable( 4 | SymbolTable(..), 5 | SortCheckM(..), 6 | SortError(..), 7 | varsInit, 8 | stabs, 9 | depSorts, 10 | simpleSorts, 11 | funSyms, 12 | axioms, 13 | reductions, 14 | iSymAxiomMap, 15 | funToAx, 16 | reducts, 17 | unJust 18 | ) where 19 | 20 | import Control.Monad.Trans.State.Lazy 21 | import Control.Monad (filterM) 22 | import Control.Monad.Trans.Class (lift) 23 | import Control.Lens 24 | 25 | import Data.Map as Map 26 | import Data.Set as Set 27 | 28 | import qualified AST 29 | import AST.Axiom as Axiom 30 | import AST.Reduction as Reduction 31 | 32 | data SymbolTable = SymbolTable { 33 | _stabs :: AST.Stab 34 | , _depSorts :: Set AST.SortName 35 | , _simpleSorts :: Set AST.SortName 36 | , _funSyms :: Map AST.Name AST.FunctionalSymbol 37 | , _axioms :: Map AST.Name Axiom 38 | , _reductions :: Map AST.Name Reduction 39 | , _iSymAxiomMap :: Map AST.Name AST.Name -- intro axioms of funSyms 40 | } 41 | 42 | makeLenses ''SymbolTable 43 | 44 | type SortCheckM = StateT SymbolTable (Either SortError) 45 | type SortError = String 46 | 47 | varsInit :: SymbolTable 48 | varsInit = SymbolTable Nothing Set.empty Set.empty Map.empty Map.empty Map.empty Map.empty 49 | 50 | funToAx :: SymbolTable -> AST.FunctionalSymbol -> Maybe Axiom 51 | funToAx table fun = do 52 | key <- Map.lookup (AST.name fun) (table^.iSymAxiomMap) 53 | Map.lookup key (table^.axioms) 54 | 55 | reducts :: SymbolTable -> AST.FunctionalSymbol -> Either String [Reduction] 56 | reducts table (AST.FunSym nm _ _) = filterM (eqTo nm) $ Map.elems (table^.reductions) 57 | where 58 | eqTo nm red = eqTo' nm (Reduction.conclusion red) 59 | eqTo' nm (AST.Reduct _ (AST.FunApp n _) _ _) = Right $ nm == n 60 | eqTo' nm x = Left $ "Error in checking, reduct must start with funsym and must be reducts\n" ++ show x 61 | 62 | 63 | unJust :: Maybe a -> a 64 | unJust (Just a) = a 65 | 66 | unJustStr :: String -> (a -> String) -> Maybe a -> String 67 | unJustStr msg _ Nothing = msg 68 | unJustStr _ f (Just a) = f a 69 | 70 | instance Show SymbolTable where 71 | show tb@(SymbolTable _ dep simp fun ax red symAx) = concat [ 72 | "Dep:\n ", AST.showCtx id (Set.toList dep), "\n", 73 | "Sim:\n ", AST.showCtx id (Set.toList simp), "\n", 74 | "Fun:", AST.showCtx (\x -> helper "\n " x ++ " intro: " ++ 75 | (unJustStr "Implementation error (or usage): no intro axiom yet!" Axiom.name . funToAx tb) x) 76 | (Map.elems fun), "\n", 77 | "Ax:_______________________", 78 | AST.showCtx (helper "\n") (Map.elems ax), "\n", 79 | "Red:______________________", 80 | AST.showCtx (helper "\n") (Map.elems red), "\n" 81 | ] 82 | where 83 | helper :: (Show a) => String -> a -> String 84 | helper pref x = pref ++ show x 85 | 86 | 87 | --- 88 | -------------------------------------------------------------------------------- /src/specLang/SortCheck/Term.hs: -------------------------------------------------------------------------------- 1 | module SortCheck.Term ( 2 | checkTerm, 3 | checkStab, 4 | checkCtxShadowing 5 | ) where 6 | 7 | import Control.Monad.Trans.State.Lazy 8 | import Control.Monad.Except (throwError) 9 | import Control.Monad.Trans.Class (lift) 10 | import Control.Lens 11 | import Control.Monad (when, unless) 12 | 13 | import qualified Data.Map as Map 14 | 15 | import AST 16 | import SortCheck.SymbolTable as SymbolTable 17 | import SortCheck.Forall (MetaCtx) 18 | 19 | checkCtxShadowing :: Ctx -> Ctx -> SortCheckM Ctx 20 | checkCtxShadowing ctx vars = do 21 | unless (allUnique $ vars ++ ctx) $ 22 | throwError $ "Added vars that shadow other vars in ctx:\n" ++ show ctx ++ show vars 23 | return $ vars ++ ctx 24 | 25 | checkTerm :: MetaCtx -> Ctx -> Term -> SortCheckM (Term, Sort) 26 | checkTerm meta ctx tm = do 27 | tm' <- fixTerm meta tm 28 | srt <- checkTerm' meta ctx tm' 29 | return (tm', srt) 30 | 31 | -- Need this as a second pass parser stage, as all identifiers are parsed as vars initially 32 | fixTerm :: MetaCtx -> Term -> SortCheckM Term 33 | fixTerm meta (Var name) = do 34 | st <- get 35 | if Map.member name (st^.SymbolTable.funSyms) 36 | then return (FunApp name []) 37 | else case lookupName (AST.mName . fst) name meta of 38 | Right (ret, _) -> return $ Meta ret 39 | Left _ -> return $ Var name 40 | 41 | fixTerm meta (FunApp f args) = do 42 | args' <- mapM (\(ct, tm) -> do 43 | tm' <- fixTerm meta tm 44 | return (ct, tm')) args 45 | return (FunApp f args') 46 | fixTerm meta (Subst wher v what) = do 47 | wher' <- fixTerm meta wher 48 | what' <- fixTerm meta what 49 | return (Subst wher' v what') 50 | 51 | -- Given a context + forall. (The sort of the term was checked) 52 | -- ??Not all high level terms have to be sort checked (only statements) 53 | checkTerm' :: MetaCtx -> Ctx -> Term -> SortCheckM Sort 54 | checkTerm' meta ctx (Var name) = 55 | if name `elem` ctx 56 | then return varSort 57 | else throwError $ name ++ " is not defined anywhere" 58 | checkTerm' meta ctx (Meta vr) = do 59 | -- so we're a metavar: check we have all we need in ctx and return our sort 60 | (mVar, sort) <- lift (lookupName (AST.mName . fst) (mName vr) meta) 61 | unless (isSubset (mContext mVar) ctx) $ 62 | throwError $ "Not all vars of a metavar are in context! Have:\n\t" ++ 63 | show ctx ++ "\nNeed:\n\t" ++ show (mContext mVar) 64 | return $ zero sort -- easy for funapps 65 | 66 | checkTerm' meta ctx fa@(FunApp f args) = do 67 | st <- get 68 | case Map.lookup f (st^.SymbolTable.funSyms) of 69 | Nothing -> throwError $ "Undefined funSym " ++ show f 70 | Just (FunSym _ needS res) -> do 71 | haveS <- mapM (\(ctx', tm) -> do 72 | ctx'' <- checkCtxShadowing ctx ctx' 73 | srt <- checkTerm' meta ctx'' tm 74 | lift $ addToCtx (length ctx') srt) args 75 | unless (needS == haveS) $ 76 | throwError $ "Arg sorts don't match, need:\n\t" ++ show needS ++ 77 | "\nbut have:\n\t" ++ show haveS ++ "\nin: " ++ show fa 78 | return res 79 | checkTerm' meta ctx ar@(Subst v varName what) = do 80 | -- v must(!) be a metavar 81 | checkMetaInSubst v 82 | -- we get: checking of compatibility of varName and v for free, 83 | -- also that v has all its' context and that it's a MetaVar 84 | ctx' <- checkCtxShadowing ctx [varName] 85 | sorte <- checkTerm' meta ctx' v 86 | -- check that the sort of what is tm 87 | whatSort <- checkTerm' meta ctx what 88 | if whatSort /= varSort 89 | then throwError $ "Can't subst " ++ show whatSort ++ " into a var of sort " ++ show varSort 90 | else return sorte 91 | 92 | checkMetaInSubst :: Term -> SortCheckM () 93 | checkMetaInSubst (Meta _) = return() 94 | checkMetaInSubst (Subst v _ _) = checkMetaInSubst v 95 | checkMetaInSubst _ = throwError "May substitute only into metavars" 96 | 97 | -- st <- checkTerm' meta (vars ++ ctx) tm 98 | -- lift $ addToCtx (length vars) st 99 | 100 | -- old subst check 101 | -- -- we check that what is a tm 102 | -- (a, b) <- lift (lookupName (AST.mName . fst) name meta) 103 | -- -- we check that out x in T[x:=term] is in our metavars context 104 | -- unless (varName `elem` mContext a) $ 105 | -- throwError "Variable substituted has to be in context" 106 | -- -- we also check that this var isn't in Judgements context 107 | -- when (varName `elem` ctx) $ 108 | -- throwError "There shouldn't be naming conflicts during subst" 109 | 110 | checkStab :: Stab -> SortCheckM Stab 111 | checkStab Nothing = return Nothing 112 | checkStab (Just sty) = do 113 | let msg = "Can't have metas or subst in stability " 114 | sty' <- mapM (fixStab msg) sty 115 | srts <- mapM (checkTerm' [] []) sty' 116 | unless (all (\x -> getSortName x == tyName && getSortDepth x == 0) srts) $ 117 | throwError $ "Sorts of terms in cstability must be (ty,0): " ++ show sty 118 | return . pure $ sty' 119 | 120 | fixStab :: String -> Term -> SortCheckM Term 121 | fixStab msg (Var nm) = do 122 | st <- get 123 | if Map.member nm (st^.SymbolTable.funSyms) 124 | then return (FunApp nm []) 125 | else return $ Var nm 126 | fixStab msg (FunApp f args) = do 127 | args' <- mapM (\(ct, tm) -> do 128 | tm' <- fixStab msg tm 129 | return (ct, tm')) args 130 | return (FunApp f args') 131 | fixStab msg _ = throwError msg 132 | 133 | 134 | 135 | 136 | --- 137 | -------------------------------------------------------------------------------- /src/specLang/parsLex/.gitignore: -------------------------------------------------------------------------------- 1 | Lexer.hs 2 | Parser.hs 3 | -------------------------------------------------------------------------------- /src/specLang/parsLex/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | -- Lexer reads tokens, add indents where needed and removes all (!) the empty newlines -- maybe this is bad, 3 | -- but otherwise is breaking my parser. (Should've read up on happy and alex more, but eh) 4 | 5 | module Lexer( 6 | Token(..) 7 | , AlexPosn(..) 8 | , TokenClass(..) 9 | , unLex 10 | , Alex(..) 11 | , runAlex' 12 | , alexMonadScan' 13 | , alexError' 14 | , mainLex 15 | ) where 16 | import Prelude hiding (lex) 17 | import Control.Monad ( liftM, forever, when ) 18 | 19 | import Debug.Trace 20 | import Data.Char 21 | import Data.List 22 | 23 | } 24 | 25 | %wrapper "monadUserState" 26 | 27 | $digit = 0-9 28 | $alpha = [A-Za-z] 29 | @indent = " " | \t 30 | 31 | tokens :- 32 | "--".* ; -- kill comments 33 | \n (@indent)* { startWhite } 34 | $digit+ { lex (TInt . read) } 35 | "DependentSorts" { lex' TDepS } 36 | "SimpleSorts" { lex' TSimpleS } 37 | "FunctionalSymbols" { lex' TFunSyms } 38 | "Axioms" { lex' TAxioms } 39 | "Reductions" { lex' TReds } 40 | "forall" { lex' TForall } 41 | "def" { lex' TDef } 42 | $alpha [$alpha $digit \_ \'\-]* { lex TIdent } 43 | "=" { lex' TEq } 44 | "=>" { lex' TReduce } 45 | ":" { lex' TColon } 46 | "|-" { lex' TTurnstile } 47 | "|--" "-"* { lex' TJudgement } 48 | "," { lex' TComma } 49 | "." { lex' TDot } 50 | "->" { lex' TArrow } 51 | "*" { lex' TTimes } 52 | "(" { lex' TLParen } 53 | ")" { lex' TRParen } 54 | "[" { lex' TLSubst } 55 | "]" { lex' TRSubst } 56 | ":=" { lex' TSubst } 57 | [\ \t\f\v]+ ; 58 | \n (@indent)* "--".* ; -- kill comments some more 59 | 60 | { 61 | 62 | data AlexUserState = AlexUserState { 63 | filePath :: FilePath, 64 | indentStack::[Int], 65 | pendingTokens::[Token] } 66 | 67 | alexInitUserState :: AlexUserState 68 | alexInitUserState = AlexUserState "" [1] [] 69 | 70 | -- The token type, consisting of the source code position and a token class. 71 | data Token = Token AlexPosn TokenClass 72 | deriving ( Show ) 73 | 74 | data TokenClass 75 | = TInt Int 76 | | TDepS 77 | | TSimpleS 78 | | TFunSyms 79 | | TAxioms 80 | | TReds 81 | | TForall 82 | | TDef 83 | | TIdent String 84 | | TEq 85 | | TColon 86 | | TTurnstile 87 | | TReduce 88 | | TJudgement 89 | | TComma 90 | | TDot 91 | | TArrow 92 | | TTimes 93 | | TLParen 94 | | TRParen 95 | | TLSubst 96 | | TRSubst 97 | | TSubst 98 | | TEOF 99 | | TIndent 100 | | TDedent 101 | | TNewLine 102 | deriving ( Show ) 103 | 104 | startWhite :: AlexInput -> Int -> Alex Token 105 | startWhite (p,_, _, _) n = do 106 | indentSt@(cur:_) <- getIndentStack 107 | when (n>cur) $ do 108 | setIndentStack (n : indentSt) 109 | setPendingTokens [Token p TIndent] 110 | when (n n) indentSt 112 | if top == n then do 113 | setIndentStack post 114 | setPendingTokens (map (const (Token p TDedent)) pre) 115 | else 116 | alexError' p "Indents don't match" 117 | return (Token p TNewLine) 118 | 119 | -- Need this apparently 120 | alexEOF :: Alex Token 121 | alexEOF = do 122 | (p,_,_,_) <- alexGetInput 123 | return $ Token p TEOF 124 | 125 | -- Unfortunately, we have to extract the matching bit of string 126 | -- ourselves... 127 | lex :: (String -> TokenClass) -> AlexAction Token 128 | lex f = \(p,_,_,s) i -> return $ Token p (f (take i s)) 129 | 130 | -- For constructing tokens that do not depend on 131 | -- the input 132 | lex' :: TokenClass -> AlexAction Token 133 | lex' = lex . const 134 | 135 | -- We rewrite alexMonadScan' to delegate to alexError' when lexing fails 136 | -- (the default implementation just returns an error message). 137 | alexMonadScan' :: Alex Token 138 | alexMonadScan' = do 139 | inp <- alexGetInput 140 | sc <- alexGetStartCode 141 | pendTok <- getPendingTokens 142 | case pendTok of 143 | -- Indents, Dedents and TEOF only 144 | t:ts -> do 145 | setPendingTokens ts 146 | return t 147 | [] -> case alexScan inp sc of 148 | AlexEOF -> do 149 | a@(p,_,_,_) <- alexGetInput 150 | rval <- startWhite a 1 151 | pt <- getPendingTokens 152 | setPendingTokens (pt ++ [Token p TEOF]) 153 | case rval of 154 | Token _ TNewLine -> alexMonadScan' 155 | _ -> return rval 156 | AlexError (p, _, _, s) -> 157 | alexError' p ("lexical error at character '" ++ take 1 s ++ "'") 158 | AlexSkip inp' _ -> do 159 | alexSetInput inp' 160 | alexMonadScan' 161 | AlexToken inp' n act -> do 162 | alexSetInput inp' 163 | tmp <- act inp n 164 | case tmp of 165 | Token _ TNewLine -> alexMonadScan' 166 | Token _ _ -> act inp n 167 | 168 | -- Signal an error, including a commonly accepted source code position. 169 | alexError' :: AlexPosn -> String -> Alex a 170 | alexError' (AlexPn _ l c) msg = do 171 | fp <- getFilePath 172 | alexError (fp ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg) 173 | 174 | -- A variant of runAlex, keeping track of the path of the file we are lexing. 175 | runAlex' :: FilePath -> String -> Alex a -> Either String a 176 | runAlex' fp input a = runAlex processedInput (setFilePath fp >> a) 177 | where processedInput = intercalate "\n" $ map (\l -> if (not $ all isSpace l) then l else "--") (lines input) 178 | 179 | readtoks:: Alex [Token] 180 | readtoks = do 181 | t<-alexMonadScan' 182 | case t of 183 | (Token _ TEOF) -> return [t] 184 | _ -> do 185 | rest<- readtoks 186 | return (t:rest) 187 | 188 | detok (Token _ d) = d 189 | 190 | printHelper (Left s) = [s] 191 | printHelper (Right r) = map (unLex . detok) r 192 | 193 | tokenize::String-> Either String [Token] 194 | tokenize s = runAlex' "sad" s readtoks 195 | 196 | mainLex :: String -> [String] 197 | mainLex input = printHelper (tokenize input) 198 | 199 | -- For nice parser error messages. 200 | unLex :: TokenClass -> String 201 | unLex (TInt i) = show i 202 | unLex TDepS = "!DepS" 203 | unLex TSimpleS = "!SimpleS" 204 | unLex TFunSyms = "!FunsSyms" 205 | unLex TAxioms = "!Axioms" 206 | unLex TReds = "!Reductions" 207 | unLex TForall = "FORALL" 208 | unLex TDef = "def" 209 | unLex (TIdent s) = s 210 | unLex TEq = "=" 211 | unLex TColon = ":" 212 | unLex TTurnstile = "|-" 213 | unLex TReduce = "=>" 214 | unLex TJudgement = "|---" 215 | unLex TComma = "," 216 | unLex TDot = "." 217 | unLex TArrow = "->" 218 | unLex TTimes = "*" 219 | unLex TLParen = "(" 220 | unLex TRParen = ")" 221 | unLex TLSubst = "[" 222 | unLex TRSubst = "]" 223 | unLex TSubst = ":=" 224 | unLex TEOF = "" 225 | unLex TIndent = "" 226 | unLex TDedent = "" 227 | unLex TNewLine = "" 228 | 229 | getFilePath :: Alex FilePath 230 | getFilePath = liftM filePath alexGetUserState 231 | 232 | getIndentStack :: Alex [Int] 233 | getIndentStack = liftM indentStack alexGetUserState 234 | 235 | getPendingTokens :: Alex [Token] 236 | getPendingTokens = liftM pendingTokens alexGetUserState 237 | 238 | setFilePath :: FilePath -> Alex () 239 | setFilePath f = do 240 | u <- alexGetUserState 241 | alexSetUserState $ AlexUserState f (indentStack u) (pendingTokens u) 242 | 243 | setIndentStack :: [Int] -> Alex () 244 | setIndentStack i = do 245 | u <- alexGetUserState 246 | alexSetUserState $ AlexUserState (filePath u) i (pendingTokens u) 247 | 248 | setPendingTokens :: [Token] -> Alex () 249 | setPendingTokens i = do 250 | u <- alexGetUserState 251 | alexSetUserState $ AlexUserState (filePath u) (indentStack u) i 252 | 253 | } 254 | -------------------------------------------------------------------------------- /src/specLang/parsLex/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | module Parser( 3 | parseLang 4 | ) where 5 | 6 | import AST 7 | import AST.Axiom as Ax 8 | import AST.Reduction as Red 9 | import Lexer 10 | 11 | } 12 | 13 | %name parse 14 | %tokentype { Token } 15 | %monad { Alex } 16 | %lexer { lexwrap } { Token _ TEOF } 17 | -- Without this we get a type error 18 | %error { happyError } 19 | 20 | %token 21 | int { Token _ (TInt $$) } 22 | ident { Token _ (TIdent $$) } 23 | depSortBeg { Token _ TDepS } 24 | simpleSortBeg { Token _ TSimpleS } 25 | funSymBeg { Token _ TFunSyms } 26 | axBeg { Token _ TAxioms } 27 | redBeg { Token _ TReds } 28 | V { Token _ TForall } 29 | def { Token _ TDef } 30 | '=' { Token _ TEq } 31 | ':' { Token _ TColon } 32 | '|-' { Token _ TTurnstile } 33 | '=>' { Token _ TReduce } 34 | '|---' { Token _ TJudgement } 35 | ',' { Token _ TComma } 36 | '.' { Token _ TDot } 37 | '->' { Token _ TArrow } 38 | '*' { Token _ TTimes } 39 | '(' { Token _ TLParen } 40 | ')' { Token _ TRParen } 41 | '[' { Token _ TLSubst } 42 | ']' { Token _ TRSubst } 43 | ':=' { Token _ TSubst } 44 | '\t' { Token _ TIndent } 45 | '/t' { Token _ TDedent } 46 | -- '\n' { Token _ TNewLine } -- currently not used in the parsing stage 47 | 48 | %% 49 | 50 | LangSpec : Sorts FunSyms AxRed 51 | { LangSpec Nothing (fst $1) (snd $1) $2 (fst $3) (snd $3) } 52 | | GlobalSts Sorts FunSyms AxRed 53 | { addStabSpec (LangSpec $1 (fst $2) (snd $2) $3 (fst $4) (snd $4)) } 54 | 55 | GlobalSts : '[' CommaSepTerms ']' { Just $2 } 56 | | '[' ']' { Just [] } 57 | 58 | Sorts : DepSorts SimpleSorts { ($1, $2) } 59 | | SimpleSorts DepSorts { ($2, $1) } 60 | | DepSorts { ($1, []) } 61 | 62 | AxRed : AxiomsAll ReductionsAll { ($1, $2) } 63 | | ReductionsAll AxiomsAll { ($2, $1) } 64 | | AxiomsAll { ($1, []) } 65 | | ReductionsAll { ([], $1) } 66 | | { ([], []) } 67 | 68 | SimpleSorts : simpleSortBeg ':' '\t' CommaSepNames '/t' { $4 } 69 | DepSorts : depSortBeg ':' '\t' CommaSepNames '/t' { $4 } 70 | CommaSepNames : ident { [$1] } 71 | | ident ',' CommaSepNames { $1 : $3 } 72 | 73 | FunSyms : funSymBeg ':' '\t' FunSymsH '/t' { $4 } 74 | FunSymsH : FunSym { [$1] } 75 | | FunSym FunSymsH { $1 : $2 } 76 | 77 | FunSym : ident ':' SortsLeft '->' ident { FunSym $1 $3 (SimpleSort $5) } -- hacky 78 | | ident ':' ident { FunSym $1 [] (SimpleSort $3) } 79 | 80 | SortsLeft : SortLeft { [$1] } 81 | | SortLeft '*' SortsLeft { $1 : $3 } 82 | SortLeft : ident { SimpleSort $1 } 83 | | '(' ident ',' int ')' { DepSort $2 $4 } 84 | 85 | AxiomsAll : axBeg ':' '\t' Axioms '/t' { $4 } 86 | ReductionsAll : redBeg ':' '\t' Reductions '/t' { $4 } 87 | 88 | Axioms : Axiom { [$1] } 89 | | Axiom Axioms { $1 : $2 } 90 | Reductions : Reduction { [$1] } 91 | | Reduction Reductions { $1 : $2 } 92 | 93 | Axiom : Header '=' '\t' Forall '\t' 94 | Premise '|---' JudgementNoEq '/t' '/t' { Axiom (snd $1) (fst $1) $4 $6 $8 } 95 | | Header '=' '\t' 96 | Premise '|---' JudgementNoEq '/t' { Axiom (snd $1) (fst $1) [] $4 $6 } 97 | 98 | Reduction : Header '=' '\t' Forall '\t' 99 | Premise '|---' JudgeReduct '/t' '/t' { Reduction (snd $1) (fst $1) $4 $6 $8 } 100 | | Header '=' '\t' 101 | Premise '|---' JudgeReduct '/t' { Reduction (snd $1) (fst $1) [] $4 $6 } 102 | 103 | 104 | Header : ident { (Nothing, $1) } 105 | | '[' CommaSepTerms ']' ident { (Just $2, $4) } 106 | | '[' ']' ident { (Just [], $3) } 107 | 108 | Forall : V ForallVars { $2 } 109 | | V { [] } -- will fix later if at all 110 | 111 | ForallVars : ForallVar { [$1] } 112 | | ForallVar ',' ForallVars { $1 : $3 } 113 | ForallVar : VarName ':' ident { ($1 , SimpleSort $3) } -- hacky 114 | VarName : ident { MetaVar [] $1 } 115 | | ident '.' ident { MetaVar [$1] $3 } 116 | | '(' SpaceSepNames ')' '.' ident { MetaVar $2 $5 } 117 | 118 | SpaceSepNames : ident { [$1] } 119 | | ident SpaceSepNames { $1 : $2 } 120 | 121 | Premise : JudgementWithEq { [$1] } 122 | | JudgementWithEq ',' Premise { $1 : $3 } 123 | | { [] } 124 | 125 | JudgementNoEq : '|-' Term ':' Term { Statement [] $2 (Just $4) } 126 | | '|-' Term def { Statement [] $2 Nothing } 127 | | Context '|-' Term ':' Term { Statement $1 $3 (Just $5) } 128 | | Context '|-' Term def { Statement $1 $3 Nothing } 129 | 130 | 131 | JudgementWithEq : JudgementNoEq { $1 } 132 | | '|-' Term '=' Term { Equality [] $2 $4 Nothing } 133 | | '|-' Term '=' Term ':' Term { Equality [] $2 $4 (Just $6) } 134 | | Context '|-' Term '=' Term { Equality $1 $3 $5 Nothing } 135 | | Context '|-' Term '=' Term ':' Term { Equality $1 $3 $5 (Just $7) } 136 | 137 | JudgeReduct : '|-' Term '=>' Term { Reduct [] $2 $4 Nothing } 138 | | '|-' Term '=>' Term ':' Term { Reduct [] $2 $4 (Just $6) } 139 | | Context '|-' Term '=>' Term { Reduct $1 $3 $5 Nothing } 140 | | Context '|-' Term '=>' Term ':' Term { Reduct $1 $3 $5 (Just $7) } 141 | 142 | 143 | Context : ident ':' Term { [($1, $3)] } 144 | | ident ':' Term ',' Context { ($1, $3) : $5 } 145 | 146 | 147 | --- neeed [] much tighter than others + no (a b). stuff on the upper levels! 148 | Term : ident { Var $1 } 149 | | ident '(' CommaSepCtTerms ')' { FunApp $1 $3 } 150 | | Term '[' ident ':=' Term ']' { Subst $1 $3 $5 } 151 | 152 | CombTerm : Term { ([], $1) } 153 | | InnerTerm { $1 } 154 | 155 | InnerTerm : ident '.' Term { ([$1], $3) } 156 | | '(' SpaceSepNames ')' '.' Term { ($2, $5) } 157 | 158 | CommaSepCtTerms : CombTerm { [$1] } 159 | | CombTerm ',' CommaSepCtTerms { $1 : $3 } 160 | 161 | CommaSepTerms : Term { [$1] } 162 | | Term ',' CommaSepTerms { $1 : $3 } 163 | 164 | 165 | { 166 | 167 | lexwrap :: (Token -> Alex a) -> Alex a 168 | lexwrap = (alexMonadScan' >>=) 169 | 170 | happyError :: Token -> Alex a 171 | happyError (Token p t) = 172 | alexError' p ("parse error at token '" ++ unLex t ++ "'") 173 | 174 | parseLang :: FilePath -> String -> Either String LangSpec 175 | parseLang fp code = runAlex' fp code parse 176 | 177 | mainParse :: FilePath -> IO () 178 | mainParse file = do 179 | str <- readFile file 180 | let k = parseLang (show file) str 181 | case k of 182 | Right x -> putStr $ show x 183 | Left x -> putStr x 184 | 185 | } 186 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.11 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # - location: 41 | # git: https://github.com/ekmett/bound/ 42 | # commit: 742d511091300f203a9f0e1b22ce02e30de55dc9 43 | # Dependency packages to be pulled from upstream that are not in the resolver 44 | # (e.g., acme-missiles-0.3) 45 | extra-deps: [] 46 | 47 | # Override default flag values for local packages and extra-deps 48 | flags: {} 49 | 50 | # Extra package databases containing global packages 51 | extra-package-dbs: [] 52 | 53 | # Control whether we use the GHC we find on the path 54 | # system-ghc: true 55 | # 56 | # Require a specific version of stack, using version ranges 57 | # require-stack-version: -any # Default 58 | # require-stack-version: ">=1.1" 59 | # 60 | # Override the architecture used by stack, especially useful on Windows 61 | # arch: i386 62 | # arch: x86_64 63 | # 64 | # Extra directories used by stack for building 65 | # extra-include-dirs: [/path/to/dir] 66 | # extra-lib-dirs: [/path/to/dir] 67 | # 68 | # Allow a newer minor version of GHC than the snapshot specifies 69 | # compiler-check: newer-minor 70 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /test/specLang/TestSortCheck.hs: -------------------------------------------------------------------------------- 1 | module TestTypeCheck 2 | where 3 | 4 | import Control.Monad.Trans.State.Lazy 5 | import Control.Monad.Except 6 | import Control.Monad.Trans.Class (lift) 7 | import Data.Maybe (isJust) 8 | import Control.Monad (when) 9 | 10 | import qualified Data.Map as Map 11 | import qualified Data.Set as Set 12 | 13 | import TypeCheck 14 | import AST 15 | 16 | funSms :: Map.Map Name FunctionalSymbol 17 | funSms = Map.fromList [] 18 | 19 | intros :: Map.Map Name Axiom 20 | intros = Map.fromList [] 21 | 22 | axims :: Map.Map Name Axiom 23 | axims = Map.fromList [] 24 | 25 | synTable :: SymbolTable 26 | synTable = SymbolTable (Set.fromList ["tm", "ty"]) Set.empty funSms 27 | axims (Map.fromList $ zip (Map.keys funSms) (Map.keys intros)) 28 | 29 | -- tests terms 30 | test1 :: TypeCheckM () 31 | test1 = do 32 | st <- get 33 | 34 | return () 35 | 36 | -------------------------------------------------------------------------------- 37 | -- Main 38 | 39 | -- State = Set DepVars, Set Vars, Map funcs, 40 | 41 | typecheck' :: TypeCheckM () -> Either TypeError SymbolTable 42 | typecheck' testFun = execStateT testFun synTable 43 | 44 | mainCheck :: TypeCheckM () -> IO () 45 | mainCheck lang = putStrLn $ 46 | case typecheck' lang of 47 | Left err -> "hmm " ++ show err 48 | x -> show x 49 | 50 | 51 | 52 | --- 53 | --------------------------------------------------------------------------------