diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index c48a1eb..db7aad4 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -25,7 +25,7 @@ jobs: stack-version: 'latest' - name: Build - run: stack build free-foil-hm + run: stack build free-foil-typecheck - name: Test run: stack test diff --git a/.github/workflows/haddock.yaml b/.github/workflows/haddock.yaml index 7128681..d2ecba0 100644 --- a/.github/workflows/haddock.yaml +++ b/.github/workflows/haddock.yaml @@ -20,7 +20,7 @@ jobs: stack-version: 'latest' - name: Build Haddock - run: stack haddock free-foil-hm + run: stack haddock free-foil-typecheck - name: Detect Haddock path run: echo "HADDOCK_DIR_PATH=$(stack path --local-doc-root)" >> $GITHUB_ENV diff --git a/README.md b/README.md index 21c5964..b83c862 100644 --- a/README.md +++ b/README.md @@ -16,13 +16,17 @@ Current goals are: ## Current progress -At the moment, our work in this repository is divided into two branches: [`system-f`](https://github.com/evermake/free-foil-typecheck/tree/system-f) and [`unification`](https://github.com/evermake/free-foil-typecheck/tree/unification), where you can find our current results on bidirectional typing and Hindley-Milner-style type inference, respectively. Currently, we're working on implementation of type checking and type inference algorithms for a concrete small language. +Our work in this repository contains implementations of bidirectional typing (System F) and Hindley-Milner-style type inference. Currently, we're working on implementing type checking and type inference algorithms for a concrete small language. -Both branches have the same directory structure: -- `grammar/` — BNFC grammar describing our concrete language syntax. -- `src/` — source code of type checker. -- `app/` — source code of REPL and interpreter binaries for playing with the current implementation. -- `test/` — scripts and test-cases with input programs for testing type checker functionality. +The repository has the following directory structure: +- `grammar/` — BNFC grammars describing concrete language syntaxes. +- `src/` — source code of type inference and type checking algorithms. +- `app/` — source code of REPL and interpreter binaries for playing with the current implementations. +- `test/` — scripts and test-cases with input programs for testing type checkers functionality. + +Contents of the mentioned directories are divided for Hindley-Milner and System F implementations. + +--- [^1]: Nikolai Kudasov, Renata Shakirova, Egor Shalagin, and Karina Tyulebaeva. 2024. Free Foil: Generating Efficient and Scope-Safe Abstract Syntax. In 2024 4th International Conference on Code Quality (ICCQ). 1–16. https://doi.org/10.1109/ICCQ60895.2024.10576867 [^2]: Abdelrahman Abounegm, Nikolai Kudasov, and Alexey Stepanov. 2024. Teaching Type Systems Implementation with Stella, an Extensible Statically Typed Programming Language. In Proceedings of the Thirteenth Workshop on Trends in Functional Programming in Education, South Orange, New Jersey, USA, 9th January 2024 (Electronic Proceedings in Theoretical Computer Science, Vol. 405), Stephen Chang (Ed.). Open Publishing Association, 1–19. https://doi.org/10.4204/EPTCS.405.1 diff --git a/Setup.hs b/Setup.hs index 2f4c35d..6ee9c71 100644 --- a/Setup.hs +++ b/Setup.hs @@ -36,12 +36,22 @@ main = [ "chcp.com" | isWindows ] <> [ "chcp.com 65001" | isWindows ] <> [ "cp grammar/hindley-milner.cf grammar/Parser.cf" -- Workaround to customize generated package name - , "bnfc --haskell -d -p HM --generic -o src grammar/Parser.cf" + , "bnfc --haskell -d -p FreeFoilTypecheck.HindleyMilner --generic -o src grammar/Parser.cf" , "rm grammar/Parser.cf" - , "cd src/HM/Parser" + , "cd src/FreeFoilTypecheck/HindleyMilner/Parser" , "alex Lex.x" , "happy Par.y" , "true" + , "cd ../../../.." + ] <> + [ "cp grammar/system-f.cf grammar/Parser.cf" -- Workaround to customize generated package name + , "bnfc --haskell -d -p FreeFoilTypecheck.SystemF --generic -o src grammar/Parser.cf" + , "rm grammar/Parser.cf" + , "cd src/FreeFoilTypecheck/SystemF/Parser" + , "alex Lex.x" + , "happy Par.y" + , "true" + , "cd ../../../.." ] fullCommand = [fmt|bash -c ' {command} '|] diff --git a/app/HindleyMilner/Interpreter.hs b/app/HindleyMilner/Interpreter.hs new file mode 100644 index 0000000..511b4c2 --- /dev/null +++ b/app/HindleyMilner/Interpreter.hs @@ -0,0 +1,18 @@ +module Main where + +import FreeFoilTypecheck.HindleyMilner.Interpret +import System.Exit + +main :: IO () +main = do + sourceCode <- getContents + case interpret sourceCode of + Success (outExpr, _) -> putStrLn (show outExpr) + Failure errorKind errorMsg -> do + putStrLn errorMsg + exitWith (ExitFailure (errorCode errorKind)) + +errorCode :: ErrorKind -> Int +errorCode ParsingError = 1 +errorCode TypecheckingError = 2 +errorCode EvaluationError = 3 diff --git a/app/Repl.hs b/app/HindleyMilner/Repl.hs similarity index 54% rename from app/Repl.hs rename to app/HindleyMilner/Repl.hs index c99cd9d..dd21d98 100644 --- a/app/Repl.hs +++ b/app/HindleyMilner/Repl.hs @@ -1,10 +1,10 @@ module Main where -import Control.Monad.Foil (emptyScope, emptyNameMap) -import HM.Eval -import HM.Parser.Par -import HM.Syntax (toExpClosed) -import HM.Typecheck +import Control.Monad.Foil (emptyScope) +import FreeFoilTypecheck.HindleyMilner.Eval +import FreeFoilTypecheck.HindleyMilner.Parser.Par +import FreeFoilTypecheck.HindleyMilner.Syntax (toExpClosed) +import FreeFoilTypecheck.HindleyMilner.Typecheck main :: IO () main = do @@ -15,10 +15,10 @@ repl :: String -> String repl input = case toExpClosed <$> pExp tokens of Left err -> "Parsing error: " ++ err - Right e -> case inferType emptyNameMap e of + Right e -> case inferTypeNewClosed e of Left err -> "Typechecking error: " ++ err Right _type -> case eval emptyScope e of - Left err -> "Evaluation error: " ++ err + Left err -> "Evaluation error: " ++ err Right outExp -> show outExp where tokens = myLexer input diff --git a/app/Interpreter.hs b/app/SystemF/Interpreter.hs similarity index 86% rename from app/Interpreter.hs rename to app/SystemF/Interpreter.hs index da5c394..a557432 100644 --- a/app/Interpreter.hs +++ b/app/SystemF/Interpreter.hs @@ -1,9 +1,10 @@ module Main where -import HM.Interpret +import FreeFoilTypecheck.SystemF.Interpret import System.Exit main :: IO () +-- main = undefined main = do sourceCode <- getContents case interpret sourceCode of diff --git a/app/SystemF/Repl.hs b/app/SystemF/Repl.hs new file mode 100644 index 0000000..5720a35 --- /dev/null +++ b/app/SystemF/Repl.hs @@ -0,0 +1,24 @@ +module Main where + +import Control.Monad.Foil (emptyNameMap) +import FreeFoilTypecheck.SystemF.Eval +import FreeFoilTypecheck.SystemF.Parser.Par +import FreeFoilTypecheck.SystemF.Syntax (toTermClosed) +import FreeFoilTypecheck.SystemF.Typecheck + +main :: IO () +main = do + putStrLn "Welcome to REPL!\n" + interact (unlines . map repl . lines) + +repl :: String -> String +repl input = + case toTermClosed <$> pTerm tokens of + Left err -> "Parsing error: " ++ err + Right e -> case inferType emptyNameMap e of + Left err -> "Typechecking error: " ++ err + Right _type -> case eval emptyNameMap e of + Left err -> "Evaluation error: " ++ err + Right outExp -> show outExp + where + tokens = myLexer input diff --git a/free-foil-hm.cabal b/free-foil-hm.cabal deleted file mode 100644 index c1435f9..0000000 --- a/free-foil-hm.cabal +++ /dev/null @@ -1,143 +0,0 @@ -cabal-version: 1.24 - --- This file has been generated from package.yaml by hpack version 0.36.0. --- --- see: https://github.com/sol/hpack - -name: free-foil-hm -version: 0.0.1 -synopsis: Hindley-Milner type system implementation powered by Free Foil. -description: Please see the README on GitHub at -category: Language -homepage: https://github.com/evermake/free-foil-hm#readme -bug-reports: https://github.com/evermake/free-foil-hm/issues -build-type: Custom -extra-source-files: - README.md - grammar/hindley-milner.cf - -source-repository head - type: git - location: https://github.com/evermake/free-foil-hm - -custom-setup - setup-depends: - Cabal >=2.4.0.1 && <4.0 - , PyF - , base >=4.11.0.0 && <5.0 - , process >=1.6.3.0 - -library - exposed-modules: - HM.Eval - HM.Interpret - HM.Parser.Abs - HM.Parser.Lex - HM.Parser.Par - HM.Parser.Print - HM.Syntax - HM.Typecheck - other-modules: - Paths_free_foil_hm - hs-source-dirs: - src - ghc-options: -Wall -Werror - build-tools: - alex >=3.2.4 - , happy >=1.19.9 - build-tool-depends: - BNFC:bnfc >=2.9.4.1 - build-depends: - array >=0.5.3.0 - , base >=4.7 && <5 - , bifunctors - , containers - , free-foil >=0.0.3 - default-language: Haskell2010 - -executable interpreter - main-is: Interpreter.hs - hs-source-dirs: - app - ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N - build-tools: - alex >=3.2.4 - , happy >=1.19.9 - build-tool-depends: - BNFC:bnfc >=2.9.4.1 - build-depends: - array >=0.5.3.0 - , base >=4.7 && <5 - , bifunctors - , containers - , free-foil >=0.0.3 - , free-foil-hm - default-language: Haskell2010 - -executable repl - main-is: Repl.hs - hs-source-dirs: - app - ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N - build-tools: - alex >=3.2.4 - , happy >=1.19.9 - build-tool-depends: - BNFC:bnfc >=2.9.4.1 - build-depends: - array >=0.5.3.0 - , base >=4.7 && <5 - , bifunctors - , containers - , free-foil >=0.0.3 - , free-foil-hm - default-language: Haskell2010 - -test-suite doctests - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: - src/ - test/doctests - ghc-options: -Wall -Werror - build-tools: - alex >=3.2.4 - , happy >=1.19.9 - build-tool-depends: - BNFC:bnfc >=2.9.4.1 - build-depends: - array >=0.5.3.0 - , base >=4.7 && <5 - , bifunctors - , containers - , doctest-parallel - , free-foil >=0.0.3 - , free-foil-hm - default-language: Haskell2010 - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - HM.InterpretSpec - Paths_free_foil_hm - hs-source-dirs: - test - ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N - build-tools: - alex >=3.2.4 - , happy >=1.19.9 - build-tool-depends: - BNFC:bnfc >=2.9.4.1 - build-depends: - array >=0.5.3.0 - , base >=4.7 && <5 - , bifunctors - , containers - , directory - , filepath - , free-foil >=0.0.3 - , free-foil-hm - , hspec - , hspec-discover - default-language: Haskell2010 diff --git a/free-foil-typecheck.cabal b/free-foil-typecheck.cabal new file mode 100644 index 0000000..a76699e --- /dev/null +++ b/free-foil-typecheck.cabal @@ -0,0 +1,193 @@ +cabal-version: 1.24 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: free-foil-typecheck +version: 0.0.1 +synopsis: Type systems implementation powered by Free Foil. +description: Please see the README on GitHub at +category: Language +homepage: https://github.com/evermake/free-foil-typecheck#readme +bug-reports: https://github.com/evermake/free-foil-typecheck/issues +build-type: Custom +extra-source-files: + README.md + grammar/hindley-milner.cf + grammar/system-f.cf + +source-repository head + type: git + location: https://github.com/evermake/free-foil-typecheck + +custom-setup + setup-depends: + Cabal >=2.4.0.1 && <4.0 + , PyF + , base >=4.11.0.0 && <5.0 + , process >=1.6.3.0 + +library + exposed-modules: + FreeFoilTypecheck.HindleyMilner.Eval + FreeFoilTypecheck.HindleyMilner.Interpret + FreeFoilTypecheck.HindleyMilner.Parser.Abs + FreeFoilTypecheck.HindleyMilner.Parser.Lex + FreeFoilTypecheck.HindleyMilner.Parser.Par + FreeFoilTypecheck.HindleyMilner.Parser.Print + FreeFoilTypecheck.HindleyMilner.Syntax + FreeFoilTypecheck.HindleyMilner.Typecheck + FreeFoilTypecheck.SystemF.Eval + FreeFoilTypecheck.SystemF.Interpret + FreeFoilTypecheck.SystemF.Parser.Abs + FreeFoilTypecheck.SystemF.Parser.Lex + FreeFoilTypecheck.SystemF.Parser.Par + FreeFoilTypecheck.SystemF.Parser.Print + FreeFoilTypecheck.SystemF.Syntax + FreeFoilTypecheck.SystemF.Syntax.Pattern + FreeFoilTypecheck.SystemF.Syntax.Term + FreeFoilTypecheck.SystemF.Typecheck + other-modules: + Paths_free_foil_typecheck + hs-source-dirs: + src + ghc-options: -Wall -Werror + build-tools: + alex >=3.2.4 + , happy >=1.19.9 + build-tool-depends: + BNFC:bnfc >=2.9.4.1 + build-depends: + array >=0.5.3.0 + , base >=4.7 && <5 + , bifunctors + , containers + , free-foil >=0.2.0 + default-language: Haskell2010 + +executable interpreter-hm + main-is: Interpreter.hs + hs-source-dirs: + app/HindleyMilner + ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N + build-tools: + alex >=3.2.4 + , happy >=1.19.9 + build-tool-depends: + BNFC:bnfc >=2.9.4.1 + build-depends: + array >=0.5.3.0 + , base >=4.7 && <5 + , bifunctors + , containers + , free-foil >=0.2.0 + , free-foil-typecheck + default-language: Haskell2010 + +executable interpreter-sf + main-is: Interpreter.hs + hs-source-dirs: + app/SystemF + ghc-options: -Wall -Werror + build-tools: + alex >=3.2.4 + , happy >=1.19.9 + build-tool-depends: + BNFC:bnfc >=2.9.4.1 + build-depends: + array >=0.5.3.0 + , base >=4.7 && <5 + , bifunctors + , containers + , free-foil >=0.2.0 + , free-foil-typecheck + default-language: Haskell2010 + +executable repl-hm + main-is: Repl.hs + hs-source-dirs: + app/HindleyMilner + ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N + build-tools: + alex >=3.2.4 + , happy >=1.19.9 + build-tool-depends: + BNFC:bnfc >=2.9.4.1 + build-depends: + array >=0.5.3.0 + , base >=4.7 && <5 + , bifunctors + , containers + , free-foil >=0.2.0 + , free-foil-typecheck + default-language: Haskell2010 + +executable repl-sf + main-is: Repl.hs + hs-source-dirs: + app/SystemF + ghc-options: -Wall -Werror + build-tools: + alex >=3.2.4 + , happy >=1.19.9 + build-tool-depends: + BNFC:bnfc >=2.9.4.1 + build-depends: + array >=0.5.3.0 + , base >=4.7 && <5 + , bifunctors + , containers + , free-foil >=0.2.0 + , free-foil-typecheck + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + src/ + test/doctests + ghc-options: -Wall -Werror + build-tools: + alex >=3.2.4 + , happy >=1.19.9 + build-tool-depends: + BNFC:bnfc >=2.9.4.1 + build-depends: + array >=0.5.3.0 + , base >=4.7 && <5 + , bifunctors + , containers + , doctest-parallel + , free-foil >=0.2.0 + , free-foil-typecheck + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + FreeFoilTypecheck.HindleyMilner.TypecheckSpec + FreeFoilTypecheck.SystemF.InterpretSpec + Paths_free_foil_typecheck + hs-source-dirs: + test + ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N + build-tools: + alex >=3.2.4 + , happy >=1.19.9 + build-tool-depends: + BNFC:bnfc >=2.9.4.1 + build-depends: + array >=0.5.3.0 + , base >=4.7 && <5 + , bifunctors + , containers + , directory + , filepath + , free-foil >=0.2.0 + , free-foil-typecheck + , hspec + , hspec-discover + default-language: Haskell2010 diff --git a/grammar/hindley-milner.cf b/grammar/hindley-milner.cf index ddcf3a3..919bf06 100644 --- a/grammar/hindley-milner.cf +++ b/grammar/hindley-milner.cf @@ -1,3 +1,5 @@ +-- Expressions grammar. + PatternVar. Pattern ::= Ident ; EVar. Exp3 ::= Ident ; @@ -10,15 +12,26 @@ EIf. Exp1 ::= "if" Exp1 "then" Exp1 "else" Exp1 ; EIsZero. Exp2 ::= "iszero" "(" Exp ")" ; ETyped. Exp ::= Exp1 ":" Type ; ELet. Exp1 ::= "let" Pattern "=" Exp1 "in" ScopedExp ; -EAbs. Exp1 ::= "λ" Pattern ":" Type "." ScopedExp ; +EAbs. Exp1 ::= "λ" Pattern "." ScopedExp ; EApp. Exp1 ::= Exp1 Exp2 ; EFor. Exp1 ::= "for" Pattern "in" "[" Exp1 ".." Exp1 "]" "do" ScopedExp ; +coercions Exp 3 ; + ScopedExp. ScopedExp ::= Exp1 ; --- https://bnfc.readthedocs.io/en/latest/lbnf.html#coercions -coercions Exp 3 ; +-- Types grammar. + +token UVarIdent ('?' letter (letter | digit | '_')*) ; +TPatternVar. TypePattern ::= Ident ; + +TUVar. Type2 ::= UVarIdent ; +TNat. Type2 ::= "Nat" ; +TBool. Type2 ::= "Bool" ; +TArrow. Type1 ::= Type2 "->" Type1 ; +TVar. Type2 ::= Ident ; +TForAll. Type ::= "forall" TypePattern "." ScopedType ; + +coercions Type 2 ; -TNat. Type ::= "Nat" ; -TBool. Type ::= "Bool" ; -TArrow. Type ::= Type "->" Type ; +ScopedType. ScopedType ::= Type1 ; diff --git a/grammar/system-f.cf b/grammar/system-f.cf new file mode 100644 index 0000000..ed5d2b0 --- /dev/null +++ b/grammar/system-f.cf @@ -0,0 +1,39 @@ +token UVarIdent ('?' letter (letter | digit | '_')*) ; ; + +PatternVar. Pattern ::= Ident ; + +EVar. Term3 ::= Ident ; +ETrue. Term3 ::= "true" ; +EFalse. Term3 ::= "false" ; +ENat. Term3 ::= Integer ; +EAdd. Term2 ::= Term2 "+" Term3 ; +ESub. Term2 ::= Term2 "-" Term3 ; +EIf. Term1 ::= "if" Term1 "then" Term1 "else" Term1 ; +EIsZero. Term2 ::= "iszero" "(" Term ")" ; +ETyped. Term ::= Term1 ":" Term ; +ELet. Term1 ::= "let" Pattern "=" Term1 "in" ScopedTerm ; +EAbsTyped. Term1 ::= "λ" Pattern ":" Term "." ScopedTerm ; +EAbsUntyped. Term1 ::= "λ" Pattern "." ScopedTerm ; +EApp. Term1 ::= Term1 Term2 ; +ETAbs. Term1 ::= "Λ" Pattern "." ScopedTerm ; +ETApp. Term1 ::= Term1 "[" Term "]" ; +EFor. Term1 ::= "for" Pattern "in" "[" Term1 ".." Term1 "]" "do" ScopedTerm ; + +-- ScopedExp. ScopedExp ::= Exp ; + +TUVar. Term3 ::= UVarIdent ; +TNat. Term3 ::= "Nat" ; +TBool. Term3 ::= "Bool" ; +TType. Term3 ::= "Type" ; +TArrow. Term2 ::= Term3 "->" Term2 ; +TForAll. Term1 ::= "forall" Pattern "." ScopedTerm ; + +-- https://bnfc.readthedocs.io/en/latest/lbnf.html#coercions +coercions Term 3 ; + +-- ScopedTerm. ScopedTerm ::= Term ; + +-- TPatternVar. TermPattern ::= Ident ; +ScopedTerm. ScopedTerm ::= Term1 ; + +-- rules EAbs. ::= EAbsTyped | EAbsUntyped ; diff --git a/package.yaml b/package.yaml index 7181451..63e781c 100644 --- a/package.yaml +++ b/package.yaml @@ -1,18 +1,14 @@ -name: free-foil-hm +name: free-foil-typecheck version: 0.0.1 -github: "evermake/free-foil-hm" +github: "evermake/free-foil-typecheck" +description: Please see the README on GitHub at +synopsis: Type systems implementation powered by Free Foil. +category: Language extra-source-files: - README.md - grammar/hindley-milner.cf - -synopsis: Hindley-Milner type system implementation powered by Free Foil. -category: Language - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at + - grammar/system-f.cf custom-setup: dependencies: @@ -31,7 +27,7 @@ dependencies: array: ">= 0.5.3.0" bifunctors: containers: - free-foil: ">= 0.0.3" + free-foil: ">= 0.2.0" ghc-options: - -Wall @@ -42,32 +38,52 @@ library: when: - condition: false other-modules: - - HM.Parser.Test - - HM.Parser.ErrM - - HM.Parser.Skel + - FreeFoilTypecheck.HindleyMilner.Parser.Test + - FreeFoilTypecheck.HindleyMilner.Parser.ErrM + - FreeFoilTypecheck.HindleyMilner.Parser.Skel + + - condition: false + other-modules: + - FreeFoilTypecheck.SystemF.Parser.Test + - FreeFoilTypecheck.SystemF.Parser.ErrM + - FreeFoilTypecheck.SystemF.Parser.Skel executables: - repl: + repl-hm: main: Repl.hs - source-dirs: app + source-dirs: app/HindleyMilner other-modules: [] ghc-options: - -threaded - -rtsopts - -with-rtsopts=-N dependencies: - - free-foil-hm + - free-foil-typecheck - interpreter: + interpreter-hm: main: Interpreter.hs - source-dirs: app + source-dirs: app/HindleyMilner other-modules: [] ghc-options: - -threaded - -rtsopts - -with-rtsopts=-N dependencies: - - free-foil-hm + - free-foil-typecheck + + repl-sf: + main: Repl.hs + source-dirs: app/SystemF + other-modules: [] + dependencies: + - free-foil-typecheck + + interpreter-sf: + main: Interpreter.hs + source-dirs: app/SystemF + other-modules: [] + dependencies: + - free-foil-typecheck tests: doctests: @@ -77,7 +93,7 @@ tests: main: Main.hs other-modules: [] dependencies: - - free-foil-hm + - free-foil-typecheck - doctest-parallel spec: @@ -88,7 +104,7 @@ tests: - -rtsopts - -with-rtsopts=-N dependencies: - - free-foil-hm + - free-foil-typecheck - hspec - hspec-discover - directory diff --git a/src/HM/Eval.hs b/src/FreeFoilTypecheck/HindleyMilner/Eval.hs similarity index 88% rename from src/HM/Eval.hs rename to src/FreeFoilTypecheck/HindleyMilner/Eval.hs index e0ab679..95bc52e 100644 --- a/src/HM/Eval.hs +++ b/src/FreeFoilTypecheck/HindleyMilner/Eval.hs @@ -1,6 +1,6 @@ {-# LANGUAGE LambdaCase #-} -module HM.Eval where +module FreeFoilTypecheck.HindleyMilner.Eval where import Control.Monad (forM) import Control.Monad.Foil @@ -10,7 +10,7 @@ import Control.Monad.Foil identitySubst, ) import Control.Monad.Free.Foil (AST (Var), substitute) -import HM.Syntax +import FreeFoilTypecheck.HindleyMilner.Syntax -- $setup -- >>> :set -XOverloadedStrings @@ -50,20 +50,20 @@ eval scope (EIsZero n) = | otherwise -> Right EFalse _ -> Left "Unsupported expression in iszero" eval scope (ETyped e _) = eval scope e -eval scope (ELet e1 x e2) = do +eval scope (ELet e1 (FoilPatternVar x) e2) = do e1' <- eval scope e1 let subst = addSubst identitySubst x e1' eval scope (substitute scope subst e2) -eval _scope (EAbs type_ x e) = Right (EAbs type_ x e) +eval _scope (EAbs x e) = Right (EAbs x e) eval scope (EApp e1 e2) = do e1' <- eval scope e1 e2' <- eval scope e2 case e1' of - EAbs _ x e -> do + EAbs (FoilPatternVar x) e -> do let subst = addSubst identitySubst x e2' eval scope (substitute scope subst e) _ -> Left "Unsupported expression in application" -eval scope (EFor e1 e2 x expr) = do +eval scope (EFor e1 e2 (FoilPatternVar x) expr) = do e1_val <- eval scope e1 e2_val <- eval scope e2 case (e1_val, e2_val) of diff --git a/src/FreeFoilTypecheck/HindleyMilner/Interpret.hs b/src/FreeFoilTypecheck/HindleyMilner/Interpret.hs new file mode 100644 index 0000000..6499e4c --- /dev/null +++ b/src/FreeFoilTypecheck/HindleyMilner/Interpret.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} + +module FreeFoilTypecheck.HindleyMilner.Interpret where + +import Control.Monad.Foil (S (VoidS), emptyScope) +import FreeFoilTypecheck.HindleyMilner.Eval +import FreeFoilTypecheck.HindleyMilner.Parser.Par +import FreeFoilTypecheck.HindleyMilner.Syntax (Exp, Type', toExpClosed) +import FreeFoilTypecheck.HindleyMilner.Typecheck + +data Result + = Success (Exp VoidS, Type') -- Output of evaluation. + | Failure ErrorKind String -- Error kind with message. + deriving (Show) + +data ErrorKind + = ParsingError + | TypecheckingError + | EvaluationError + deriving (Show) + +interpret :: String -> Result +interpret input = + case toExpClosed <$> pExp tokens of + Left err -> Failure ParsingError ("Parsing error: " ++ err) + Right e -> case inferTypeNewClosed e of + Left err -> Failure TypecheckingError ("Typechecking error: " ++ err) + Right type_ -> case eval emptyScope e of + Left err -> Failure EvaluationError ("Evaluation error: " ++ err) + Right outExp -> Success (outExp, type_) + where + tokens = myLexer input diff --git a/src/HM/Parser/Abs.hs b/src/FreeFoilTypecheck/HindleyMilner/Parser/Abs.hs similarity index 67% rename from src/HM/Parser/Abs.hs rename to src/FreeFoilTypecheck/HindleyMilner/Parser/Abs.hs index 0c05c9c..2ed7dff 100644 --- a/src/HM/Parser/Abs.hs +++ b/src/FreeFoilTypecheck/HindleyMilner/Parser/Abs.hs @@ -6,7 +6,7 @@ -- | The abstract syntax of language Parser. -module HM.Parser.Abs where +module FreeFoilTypecheck.HindleyMilner.Parser.Abs where import Prelude (Integer, String) import qualified Prelude as C (Eq, Ord, Show, Read) @@ -29,7 +29,7 @@ data Exp | EIsZero Exp | ETyped Exp Type | ELet Pattern Exp ScopedExp - | EAbs Pattern Type ScopedExp + | EAbs Pattern ScopedExp | EApp Exp Exp | EFor Pattern Exp Exp ScopedExp deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) @@ -37,9 +37,24 @@ data Exp data ScopedExp = ScopedExp Exp deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) -data Type = TNat | TBool | TArrow Type Type +data TypePattern = TPatternVar Ident + deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) + +data Type + = TUVar UVarIdent + | TNat + | TBool + | TArrow Type Type + | TVar Ident + | TForAll TypePattern ScopedType + deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) + +data ScopedType = ScopedType Type deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) newtype Ident = Ident String deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic, Data.String.IsString) +newtype UVarIdent = UVarIdent String + deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic, Data.String.IsString) + diff --git a/src/HM/Parser/Doc.txt b/src/FreeFoilTypecheck/HindleyMilner/Parser/Doc.txt similarity index 78% rename from src/HM/Parser/Doc.txt rename to src/FreeFoilTypecheck/HindleyMilner/Parser/Doc.txt index fa9e253..0b906da 100644 --- a/src/HM/Parser/Doc.txt +++ b/src/FreeFoilTypecheck/HindleyMilner/Parser/Doc.txt @@ -21,14 +21,18 @@ Integer literals //Integer// are nonempty sequences of digits. +UVarIdent literals are recognized by the regular expression +`````'?' letter ('_' | digit | letter)*````` + + ===Reserved words and symbols=== The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions. The reserved words used in Parser are the following: | ``Bool`` | ``Nat`` | ``do`` | ``else`` - | ``false`` | ``for`` | ``if`` | ``in`` - | ``iszero`` | ``let`` | ``then`` | ``true`` - | ``λ`` | | | + | ``false`` | ``for`` | ``forall`` | ``if`` + | ``in`` | ``iszero`` | ``let`` | ``then`` + | ``true`` | ``λ`` | | The symbols used in Parser are the following: | + | - | ( | ) @@ -56,16 +60,24 @@ All other symbols are terminals. | | **|** | //Exp3// | //Exp1// | -> | ``if`` //Exp1// ``then`` //Exp1// ``else`` //Exp1// | | **|** | ``let`` //Pattern// ``=`` //Exp1// ``in`` //ScopedExp// - | | **|** | ``λ`` //Pattern// ``:`` //Type// ``.`` //ScopedExp// + | | **|** | ``λ`` //Pattern// ``.`` //ScopedExp// | | **|** | //Exp1// //Exp2// | | **|** | ``for`` //Pattern// ``in`` ``[`` //Exp1// ``..`` //Exp1// ``]`` ``do`` //ScopedExp// | | **|** | //Exp2// | //Exp// | -> | //Exp1// ``:`` //Type// | | **|** | //Exp1// | //ScopedExp// | -> | //Exp1// - | //Type// | -> | ``Nat`` + | //TypePattern// | -> | //Ident// + | //Type2// | -> | //UVarIdent// + | | **|** | ``Nat`` | | **|** | ``Bool`` - | | **|** | //Type// ``->`` //Type// + | | **|** | //Ident// + | | **|** | ``(`` //Type// ``)`` + | //Type1// | -> | //Type2// ``->`` //Type1// + | | **|** | //Type2// + | //Type// | -> | ``forall`` //TypePattern// ``.`` //ScopedType// + | | **|** | //Type1// + | //ScopedType// | -> | //Type1// diff --git a/src/FreeFoilTypecheck/HindleyMilner/Parser/ErrM.hs b/src/FreeFoilTypecheck/HindleyMilner/Parser/ErrM.hs new file mode 100644 index 0000000..d47eb70 --- /dev/null +++ b/src/FreeFoilTypecheck/HindleyMilner/Parser/ErrM.hs @@ -0,0 +1,91 @@ +-- File generated by the BNF Converter (bnfc 2.9.5). + +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 708 +--------------------------------------------------------------------------- +-- Pattern synonyms exist since ghc 7.8. + +-- | BNF Converter: Error Monad. +-- +-- Module for backwards compatibility. +-- +-- The generated parser now uses @'Either' String@ as error monad. +-- This module defines a type synonym 'Err' and pattern synonyms +-- 'Bad' and 'Ok' for 'Left' and 'Right'. + +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleInstances #-} + +module FreeFoilTypecheck.HindleyMilner.Parser.ErrM where + +import Prelude (id, const, Either(..), String) + +import Control.Monad (MonadPlus(..)) +import Control.Applicative (Alternative(..)) +#if __GLASGOW_HASKELL__ >= 808 +import Control.Monad (MonadFail(..)) +#endif + +-- | Error monad with 'String' error messages. +type Err = Either String + +pattern Bad msg = Left msg +pattern Ok a = Right a + +#if __GLASGOW_HASKELL__ >= 808 +instance MonadFail Err where + fail = Bad +#endif + +instance Alternative Err where + empty = Left "Err.empty" + (<|>) Left{} = id + (<|>) x@Right{} = const x + +instance MonadPlus Err where + mzero = empty + mplus = (<|>) + +#else +--------------------------------------------------------------------------- +-- ghc 7.6 and before: use old definition as data type. + +-- | BNF Converter: Error Monad + +-- Copyright (C) 2004 Author: Aarne Ranta +-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE. + +module FreeFoilTypecheck.HindleyMilner.Parser.ErrM where + +-- the Error monad: like Maybe type with error msgs + +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Monad (MonadPlus(..), liftM) + +data Err a = Ok a | Bad String + deriving (Read, Show, Eq, Ord) + +instance Monad Err where + return = Ok + Ok a >>= f = f a + Bad s >>= _ = Bad s + +instance Applicative Err where + pure = Ok + (Bad s) <*> _ = Bad s + (Ok f) <*> o = liftM f o + +instance Functor Err where + fmap = liftM + +instance MonadPlus Err where + mzero = Bad "Err.mzero" + mplus (Bad _) y = y + mplus x _ = x + +instance Alternative Err where + empty = mzero + (<|>) = mplus + +#endif diff --git a/src/HM/Parser/Lex.hs b/src/FreeFoilTypecheck/HindleyMilner/Parser/Lex.hs similarity index 77% rename from src/HM/Parser/Lex.hs rename to src/FreeFoilTypecheck/HindleyMilner/Parser/Lex.hs index d7a850f..10ff2ef 100644 --- a/src/HM/Parser/Lex.hs +++ b/src/FreeFoilTypecheck/HindleyMilner/Parser/Lex.hs @@ -9,7 +9,7 @@ {-# LANGUAGE PatternSynonyms #-} -module HM.Parser.Lex where +module FreeFoilTypecheck.HindleyMilner.Parser.Lex where import Prelude @@ -22,283 +22,516 @@ import qualified Data.Array alex_tab_size :: Int alex_tab_size = 8 alex_base :: Data.Array.Array Int Int -alex_base = Data.Array.listArray (0 :: Int, 8) +alex_base = Data.Array.listArray (0 :: Int, 11) [ -8 - , -181 - , 0 - , -2 - , -13 - , -50 - , -35 , 140 - , -23 + , -13 + , 239 + , -42 + , -46 + , 234 + , 170 + , 0 + , -170 + , -28 + , 370 ] alex_table :: Data.Array.Array Int Int -alex_table = Data.Array.listArray (0 :: Int, 395) +alex_table = Data.Array.listArray (0 :: Int, 625) [ 0 + , 7 + , 7 + , 7 + , 7 + , 7 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 8 + , 8 + , 8 + , 0 + , 0 + , 0 + , 0 + , 0 + , 7 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 8 + , 8 + , 0 + , 8 + , 0 + , 5 + , 10 + , 0 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 4 + , 8 + , 0 + , 0 + , 8 + , 0 + , 11 + , 0 + , 3 + , 3 + , 3 + , 3 , 3 , 3 , 3 , 3 , 3 - , 2 , 3 , 3 , 3 , 3 , 3 - , 2 - , 6 - , 6 - , 6 - , 6 - , 6 - , 6 - , 6 - , 6 - , 6 - , 6 - , 2 , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 8 , 0 + , 8 , 0 , 0 , 0 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 , 0 , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 , 0 - , 2 - , 2 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 7 + , 7 + , 7 + , 7 + , 7 , 0 - , 2 , 0 - , 5 - , 8 , 0 - , 6 - , 6 - , 6 - , 6 - , 6 - , 6 - , 6 - , 6 - , 6 - , 6 , 2 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 9 , 0 , 0 - , 2 , 0 + , 7 , 0 , 0 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 2 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 , 0 - , 2 , 0 , 0 , 0 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 + , 1 + , 0 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 3 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 0 + , 0 , 0 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 , 0 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 , 0 , 0 , 0 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 , 0 , 0 , 0 , 0 - , 4 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 + , 3 + , 6 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 3 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 , 1 , 0 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 , 0 , 0 , 0 , 0 , 0 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 , 0 , 0 , 0 + , 2 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 , 0 - , 7 , 0 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 - , 7 + , 0 + , 0 + , 0 + , 0 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 , 0 , 0 , 0 @@ -371,7 +604,7 @@ alex_table = Data.Array.listArray (0 :: Int, 395) , 0 , 0 , 0 - , 4 + , 6 , 0 , 0 , 0 @@ -434,21 +667,14 @@ alex_table = Data.Array.listArray (0 :: Int, 395) , 0 ] -alex_check :: Data.Array.Array Int Int -alex_check = Data.Array.listArray (0 :: Int, 395) - [ -1 - , 9 - , 10 - , 11 - , 12 - , 13 - , 187 +alex_check :: Data.Array.Array Int Int +alex_check = Data.Array.listArray (0 :: Int, 625) + [ -1 , 9 , 10 , 11 , 12 , 13 - , 62 , 48 , 49 , 50 @@ -459,8 +685,9 @@ alex_check = Data.Array.listArray (0 :: Int, 395) , 55 , 56 , 57 + , 62 + , 187 , 46 - , 32 , -1 , -1 , -1 @@ -468,6 +695,12 @@ alex_check = Data.Array.listArray (0 :: Int, 395) , -1 , 32 , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 , 40 , 41 , -1 @@ -491,7 +724,7 @@ alex_check = Data.Array.listArray (0 :: Int, 395) , -1 , 61 , -1 - , -1 + , 63 , -1 , 65 , 66 @@ -615,6 +848,105 @@ alex_check = Data.Array.listArray (0 :: Int, 395) , 189 , 190 , 191 + , 9 + , 10 + , 11 + , 12 + , 13 + , -1 + , -1 + , -1 + , 195 + , 48 + , 49 + , 50 + , 51 + , 52 + , 53 + , 54 + , 55 + , 56 + , 57 + , 206 + , -1 + , -1 + , -1 + , 32 + , -1 + , -1 + , 65 + , 66 + , 67 + , 68 + , 69 + , 70 + , 71 + , 72 + , 73 + , 74 + , 75 + , 76 + , 77 + , 78 + , 79 + , 80 + , 81 + , 82 + , 83 + , 84 + , 85 + , 86 + , 87 + , 88 + , 89 + , 90 + , -1 + , -1 + , -1 + , -1 + , 95 + , -1 + , 97 + , 98 + , 99 + , 100 + , 101 + , 102 + , 103 + , 104 + , 105 + , 106 + , 107 + , 108 + , 109 + , 110 + , 111 + , 112 + , 113 + , 114 + , 115 + , 116 + , 117 + , 118 + , 119 + , 120 + , 121 + , 122 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 , 39 , -1 , -1 @@ -623,7 +955,7 @@ alex_check = Data.Array.listArray (0 :: Int, 395) , -1 , -1 , -1 - , 195 + , -1 , 48 , 49 , 50 @@ -634,7 +966,7 @@ alex_check = Data.Array.listArray (0 :: Int, 395) , 55 , 56 , 57 - , 206 + , -1 , -1 , -1 , -1 @@ -672,6 +1004,137 @@ alex_check = Data.Array.listArray (0 :: Int, 395) , -1 , -1 , 95 + , 195 + , 97 + , 98 + , 99 + , 100 + , 101 + , 102 + , 103 + , 104 + , 105 + , 106 + , 107 + , 108 + , 109 + , 110 + , 111 + , 112 + , 113 + , 114 + , 115 + , 116 + , 117 + , 118 + , 119 + , 120 + , 121 + , 122 + , 128 + , 129 + , 130 + , 131 + , 132 + , 133 + , 134 + , 135 + , 136 + , 137 + , 138 + , 139 + , 140 + , 141 + , 142 + , 143 + , 144 + , 145 + , 146 + , 147 + , 148 + , 149 + , 150 + , -1 + , 152 + , 153 + , 154 + , 155 + , 156 + , 157 + , 158 + , 159 + , 160 + , 161 + , 162 + , 163 + , 164 + , 165 + , 166 + , 167 + , 168 + , 169 + , 170 + , 171 + , 172 + , 173 + , 174 + , 175 + , 176 + , 177 + , 178 + , 179 + , 180 + , 181 + , 182 + , -1 + , 184 + , 185 + , 186 + , 187 + , 188 + , 189 + , 190 + , 191 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , 195 + , 65 + , 66 + , 67 + , 68 + , 69 + , 70 + , 71 + , 72 + , 73 + , 74 + , 75 + , 76 + , 77 + , 78 + , 79 + , 80 + , 81 + , 82 + , 83 + , 84 + , 85 + , 86 + , 87 + , 88 + , 89 + , 90 + , -1 + , -1 + , -1 + , -1 + , -1 , -1 , 97 , 98 @@ -835,7 +1298,7 @@ alex_check = Data.Array.listArray (0 :: Int, 395) ] alex_deflt :: Data.Array.Array Int Int -alex_deflt = Data.Array.listArray (0 :: Int, 8) +alex_deflt = Data.Array.listArray (0 :: Int, 11) [ -1 , -1 , -1 @@ -845,31 +1308,39 @@ alex_deflt = Data.Array.listArray (0 :: Int, 8) , -1 , -1 , -1 + , -1 + , -1 + , -1 ] -alex_accept = Data.Array.listArray (0 :: Int, 8) +alex_accept = Data.Array.listArray (0 :: Int, 11) [ AlexAccNone + , AlexAcc 5 , AlexAccNone , AlexAcc 4 - , AlexAccSkip - , AlexAccNone , AlexAcc 3 , AlexAcc 2 + , AlexAccNone + , AlexAccSkip , AlexAcc 1 + , AlexAccNone , AlexAcc 0 + , AlexAccNone ] -alex_actions = Data.Array.array (0 :: Int, 5) - [ (4,alex_action_1) - , (3,alex_action_1) - , (2,alex_action_3) - , (1,alex_action_2) +alex_actions = Data.Array.array (0 :: Int, 6) + [ (5,alex_action_2) + , (4,alex_action_3) + , (3,alex_action_4) + , (2,alex_action_1) + , (1,alex_action_1) , (0,alex_action_1) ] alex_action_1 = tok (eitherResIdent TV) -alex_action_2 = tok (eitherResIdent TV) -alex_action_3 = tok TI +alex_action_2 = tok (eitherResIdent T_UVarIdent) +alex_action_3 = tok (eitherResIdent TV) +alex_action_4 = tok TI #define ALEX_NOPRED 1 -- ----------------------------------------------------------------------------- @@ -1103,7 +1574,7 @@ alexRightContext IBOX(sc) user__ _ _ input__ = -- match when checking the right context, just -- the first match will do. #endif -{-# LINE 50 "Lex.x" #-} +{-# LINE 54 "Lex.x" #-} -- | Create a token with position. tok :: (String -> Tok) -> (Posn -> String -> Token) tok f p = PT p . f @@ -1116,6 +1587,7 @@ data Tok | TV !String -- ^ Identifier. | TD !String -- ^ Float literal. | TC !String -- ^ Character literal. + | T_UVarIdent !String deriving (Eq, Show, Ord) -- | Smart constructor for 'Tok' for the sake of backwards compatibility. @@ -1178,6 +1650,7 @@ tokenText t = case t of PT _ (TD s) -> s PT _ (TC s) -> s Err _ -> "#error" + PT _ (T_UVarIdent s) -> s -- | Convert a token to a string. prToken :: Token -> String @@ -1210,12 +1683,13 @@ resWords = (b ")" 2 (b "(" 1 N N) (b "+" 3 N N)) (b "." 6 (b "->" 5 N N) N)) (b "Bool" 10 (b "=" 9 (b ":" 8 N N) N) (b "[" 12 (b "Nat" 11 N N) N))) - (b "in" 19 - (b "false" 16 - (b "else" 15 (b "do" 14 N N) N) (b "if" 18 (b "for" 17 N N) N)) - (b "then" 22 - (b "let" 21 (b "iszero" 20 N N) N) - (b "\955" 24 (b "true" 23 N N) N))) + (b "in" 20 + (b "for" 17 + (b "else" 15 (b "do" 14 N N) (b "false" 16 N N)) + (b "if" 19 (b "forall" 18 N N) N)) + (b "then" 23 + (b "let" 22 (b "iszero" 21 N N) N) + (b "\955" 25 (b "true" 24 N N) N))) where b s n = B bs (TS bs n) where diff --git a/src/HM/Parser/Lex.x b/src/FreeFoilTypecheck/HindleyMilner/Parser/Lex.x similarity index 93% rename from src/HM/Parser/Lex.x rename to src/FreeFoilTypecheck/HindleyMilner/Parser/Lex.x index 2fd9e9c..67be055 100644 --- a/src/HM/Parser/Lex.x +++ b/src/FreeFoilTypecheck/HindleyMilner/Parser/Lex.x @@ -7,7 +7,7 @@ {-# LANGUAGE PatternSynonyms #-} -module HM.Parser.Lex where +module FreeFoilTypecheck.HindleyMilner.Parser.Lex where import Prelude @@ -39,6 +39,10 @@ $white+ ; @rsyms { tok (eitherResIdent TV) } +-- token UVarIdent +\? $l (\_ | ($d | $l)) * + { tok (eitherResIdent T_UVarIdent) } + -- Keywords and Ident $l $i* { tok (eitherResIdent TV) } @@ -60,6 +64,7 @@ data Tok | TV !String -- ^ Identifier. | TD !String -- ^ Float literal. | TC !String -- ^ Character literal. + | T_UVarIdent !String deriving (Eq, Show, Ord) -- | Smart constructor for 'Tok' for the sake of backwards compatibility. @@ -122,6 +127,7 @@ tokenText t = case t of PT _ (TD s) -> s PT _ (TC s) -> s Err _ -> "#error" + PT _ (T_UVarIdent s) -> s -- | Convert a token to a string. prToken :: Token -> String @@ -154,12 +160,13 @@ resWords = (b ")" 2 (b "(" 1 N N) (b "+" 3 N N)) (b "." 6 (b "->" 5 N N) N)) (b "Bool" 10 (b "=" 9 (b ":" 8 N N) N) (b "[" 12 (b "Nat" 11 N N) N))) - (b "in" 19 - (b "false" 16 - (b "else" 15 (b "do" 14 N N) N) (b "if" 18 (b "for" 17 N N) N)) - (b "then" 22 - (b "let" 21 (b "iszero" 20 N N) N) - (b "\955" 24 (b "true" 23 N N) N))) + (b "in" 20 + (b "for" 17 + (b "else" 15 (b "do" 14 N N) (b "false" 16 N N)) + (b "if" 19 (b "forall" 18 N N) N)) + (b "then" 23 + (b "let" 22 (b "iszero" 21 N N) N) + (b "\955" 25 (b "true" 24 N N) N))) where b s n = B bs (TS bs n) where diff --git a/src/FreeFoilTypecheck/HindleyMilner/Parser/Par.hs b/src/FreeFoilTypecheck/HindleyMilner/Parser/Par.hs new file mode 100644 index 0000000..14f39b0 --- /dev/null +++ b/src/FreeFoilTypecheck/HindleyMilner/Parser/Par.hs @@ -0,0 +1,1581 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module FreeFoilTypecheck.HindleyMilner.Parser.Par + ( happyError + , myLexer + , pPattern + , pExp3 + , pExp2 + , pExp1 + , pExp + , pScopedExp + , pTypePattern + , pType2 + , pType1 + , pType + , pScopedType + ) where + +import Prelude + +import qualified FreeFoilTypecheck.HindleyMilner.Parser.Abs +import FreeFoilTypecheck.HindleyMilner.Parser.Lex +import qualified Data.Array as Happy_Data_Array +import qualified Data.Bits as Bits +import Control.Applicative(Applicative(..)) +import Control.Monad (ap) + +-- parser produced by Happy Version 1.20.1.1 + +data HappyAbsSyn + = HappyTerminal (Token) + | HappyErrorToken Prelude.Int + | HappyAbsSyn14 (FreeFoilTypecheck.HindleyMilner.Parser.Abs.Ident) + | HappyAbsSyn15 (Integer) + | HappyAbsSyn16 (FreeFoilTypecheck.HindleyMilner.Parser.Abs.UVarIdent) + | HappyAbsSyn17 (FreeFoilTypecheck.HindleyMilner.Parser.Abs.Pattern) + | HappyAbsSyn18 (FreeFoilTypecheck.HindleyMilner.Parser.Abs.Exp) + | HappyAbsSyn22 (FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedExp) + | HappyAbsSyn23 (FreeFoilTypecheck.HindleyMilner.Parser.Abs.TypePattern) + | HappyAbsSyn24 (FreeFoilTypecheck.HindleyMilner.Parser.Abs.Type) + | HappyAbsSyn27 (FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedType) + +{- to allow type-synonyms as our monads (likely + - with explicitly-specified bind and return) + - in Haskell98, it seems that with + - /type M a = .../, then /(HappyReduction M)/ + - is not allowed. But Happy is a + - code-generator that can just substitute it. +type HappyReduction m = + Prelude.Int + -> (Token) + -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn) + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> m HappyAbsSyn +-} + +action_0, + action_1, + action_2, + action_3, + action_4, + action_5, + action_6, + action_7, + action_8, + action_9, + action_10, + action_11, + action_12, + action_13, + action_14, + action_15, + action_16, + action_17, + action_18, + action_19, + action_20, + action_21, + action_22, + action_23, + action_24, + action_25, + action_26, + action_27, + action_28, + action_29, + action_30, + action_31, + action_32, + action_33, + action_34, + action_35, + action_36, + action_37, + action_38, + action_39, + action_40, + action_41, + action_42, + action_43, + action_44, + action_45, + action_46, + action_47, + action_48, + action_49, + action_50, + action_51, + action_52, + action_53, + action_54, + action_55, + action_56, + action_57, + action_58, + action_59, + action_60, + action_61, + action_62, + action_63, + action_64, + action_65, + action_66, + action_67, + action_68, + action_69, + action_70, + action_71, + action_72, + action_73, + action_74, + action_75, + action_76, + action_77, + action_78, + action_79, + action_80, + action_81, + action_82, + action_83, + action_84, + action_85, + action_86, + action_87, + action_88, + action_89, + action_90, + action_91 :: () => Prelude.Int -> ({-HappyReduction (Err) = -} + Prelude.Int + -> (Token) + -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> (Err) HappyAbsSyn) + +happyReduce_11, + happyReduce_12, + happyReduce_13, + happyReduce_14, + happyReduce_15, + happyReduce_16, + happyReduce_17, + happyReduce_18, + happyReduce_19, + happyReduce_20, + happyReduce_21, + happyReduce_22, + happyReduce_23, + happyReduce_24, + happyReduce_25, + happyReduce_26, + happyReduce_27, + happyReduce_28, + happyReduce_29, + happyReduce_30, + happyReduce_31, + happyReduce_32, + happyReduce_33, + happyReduce_34, + happyReduce_35, + happyReduce_36, + happyReduce_37, + happyReduce_38, + happyReduce_39, + happyReduce_40, + happyReduce_41, + happyReduce_42, + happyReduce_43 :: () => ({-HappyReduction (Err) = -} + Prelude.Int + -> (Token) + -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> (Err) HappyAbsSyn) + +happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int +happyExpList = Happy_Data_Array.listArray (0,314) ([0,0,0,16,0,8,13316,0,2048,33792,52,0,8,15788,0,2048,44032,61,0,8,15788,0,0,0,16,0,12296,20480,0,2048,48,80,0,12296,20496,0,2048,48,80,0,0,4096,0,0,0,0,0,0,0,0,0,0,0,0,128,0,0,0,0,0,0,0,0,0,2048,4144,80,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,24576,0,0,0,0,0,0,0,0,0,0,8,15788,0,0,0,0,0,0,4096,0,2048,44032,61,0,8,0,0,0,0,16,0,0,0,0,0,0,16,0,0,0,0,2048,33796,52,0,0,0,0,2048,33792,52,0,96,0,0,0,0,0,0,0,0,0,0,0,0,0,8,13316,0,2048,1024,52,0,96,0,0,2048,4144,80,0,256,0,0,0,8,0,0,8,15788,0,2048,33792,54,0,0,64,0,4096,0,0,0,256,0,0,4096,0,0,0,12296,20480,0,0,0,0,0,0,0,0,2048,48,80,0,0,0,0,0,64,0,0,8,15788,0,4096,0,0,0,8,15788,0,2048,44032,61,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,8,13508,0,0,0,0,0,8,13446,0,2048,44032,61,0,0,0,0,2048,33794,52,0,8,15788,0,2048,44032,61,0,0,0,0,0,0,0,0,8,15788,0,2048,33920,52,0,0,1,0,2048,44032,61,0,0,0,0 + ]) + +{-# NOINLINE happyExpListPerState #-} +happyExpListPerState st = + token_strs_expected + where token_strs = ["error","%dummy","%start_pPattern","%start_pExp3","%start_pExp2","%start_pExp1","%start_pExp","%start_pScopedExp","%start_pTypePattern","%start_pType2","%start_pType1","%start_pType","%start_pScopedType","Ident","Integer","UVarIdent","Pattern","Exp3","Exp2","Exp1","Exp","ScopedExp","TypePattern","Type2","Type1","Type","ScopedType","'('","')'","'+'","'-'","'->'","'.'","'..'","':'","'='","'Bool'","'Nat'","'['","']'","'do'","'else'","'false'","'for'","'forall'","'if'","'in'","'iszero'","'let'","'then'","'true'","'\955'","L_Ident","L_integ","L_UVarIdent","%eof"] + bit_start = st Prelude.* 56 + bit_end = (st Prelude.+ 1) Prelude.* 56 + read_bit = readArrayBit happyExpList + bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] + bits_indexed = Prelude.zip bits [0..55] + token_strs_expected = Prelude.concatMap f bits_indexed + f (Prelude.False, _) = [] + f (Prelude.True, nr) = [token_strs Prelude.!! nr] + +action_0 (53) = happyShift action_12 +action_0 (14) = happyGoto action_49 +action_0 (17) = happyGoto action_50 +action_0 _ = happyFail (happyExpListPerState 0) + +action_1 (28) = happyShift action_35 +action_1 (43) = happyShift action_36 +action_1 (51) = happyShift action_41 +action_1 (53) = happyShift action_12 +action_1 (54) = happyShift action_43 +action_1 (14) = happyGoto action_29 +action_1 (15) = happyGoto action_30 +action_1 (18) = happyGoto action_48 +action_1 _ = happyFail (happyExpListPerState 1) + +action_2 (28) = happyShift action_35 +action_2 (43) = happyShift action_36 +action_2 (48) = happyShift action_39 +action_2 (51) = happyShift action_41 +action_2 (53) = happyShift action_12 +action_2 (54) = happyShift action_43 +action_2 (14) = happyGoto action_29 +action_2 (15) = happyGoto action_30 +action_2 (18) = happyGoto action_31 +action_2 (19) = happyGoto action_47 +action_2 _ = happyFail (happyExpListPerState 2) + +action_3 (28) = happyShift action_35 +action_3 (43) = happyShift action_36 +action_3 (44) = happyShift action_37 +action_3 (46) = happyShift action_38 +action_3 (48) = happyShift action_39 +action_3 (49) = happyShift action_40 +action_3 (51) = happyShift action_41 +action_3 (52) = happyShift action_42 +action_3 (53) = happyShift action_12 +action_3 (54) = happyShift action_43 +action_3 (14) = happyGoto action_29 +action_3 (15) = happyGoto action_30 +action_3 (18) = happyGoto action_31 +action_3 (19) = happyGoto action_32 +action_3 (20) = happyGoto action_46 +action_3 _ = happyFail (happyExpListPerState 3) + +action_4 (28) = happyShift action_35 +action_4 (43) = happyShift action_36 +action_4 (44) = happyShift action_37 +action_4 (46) = happyShift action_38 +action_4 (48) = happyShift action_39 +action_4 (49) = happyShift action_40 +action_4 (51) = happyShift action_41 +action_4 (52) = happyShift action_42 +action_4 (53) = happyShift action_12 +action_4 (54) = happyShift action_43 +action_4 (14) = happyGoto action_29 +action_4 (15) = happyGoto action_30 +action_4 (18) = happyGoto action_31 +action_4 (19) = happyGoto action_32 +action_4 (20) = happyGoto action_44 +action_4 (21) = happyGoto action_45 +action_4 _ = happyFail (happyExpListPerState 4) + +action_5 (28) = happyShift action_35 +action_5 (43) = happyShift action_36 +action_5 (44) = happyShift action_37 +action_5 (46) = happyShift action_38 +action_5 (48) = happyShift action_39 +action_5 (49) = happyShift action_40 +action_5 (51) = happyShift action_41 +action_5 (52) = happyShift action_42 +action_5 (53) = happyShift action_12 +action_5 (54) = happyShift action_43 +action_5 (14) = happyGoto action_29 +action_5 (15) = happyGoto action_30 +action_5 (18) = happyGoto action_31 +action_5 (19) = happyGoto action_32 +action_5 (20) = happyGoto action_33 +action_5 (22) = happyGoto action_34 +action_5 _ = happyFail (happyExpListPerState 5) + +action_6 (53) = happyShift action_12 +action_6 (14) = happyGoto action_27 +action_6 (23) = happyGoto action_28 +action_6 _ = happyFail (happyExpListPerState 6) + +action_7 (28) = happyShift action_18 +action_7 (37) = happyShift action_19 +action_7 (38) = happyShift action_20 +action_7 (53) = happyShift action_12 +action_7 (55) = happyShift action_21 +action_7 (14) = happyGoto action_13 +action_7 (16) = happyGoto action_14 +action_7 (24) = happyGoto action_26 +action_7 _ = happyFail (happyExpListPerState 7) + +action_8 (28) = happyShift action_18 +action_8 (37) = happyShift action_19 +action_8 (38) = happyShift action_20 +action_8 (53) = happyShift action_12 +action_8 (55) = happyShift action_21 +action_8 (14) = happyGoto action_13 +action_8 (16) = happyGoto action_14 +action_8 (24) = happyGoto action_15 +action_8 (25) = happyGoto action_25 +action_8 _ = happyFail (happyExpListPerState 8) + +action_9 (28) = happyShift action_18 +action_9 (37) = happyShift action_19 +action_9 (38) = happyShift action_20 +action_9 (45) = happyShift action_24 +action_9 (53) = happyShift action_12 +action_9 (55) = happyShift action_21 +action_9 (14) = happyGoto action_13 +action_9 (16) = happyGoto action_14 +action_9 (24) = happyGoto action_15 +action_9 (25) = happyGoto action_22 +action_9 (26) = happyGoto action_23 +action_9 _ = happyFail (happyExpListPerState 9) + +action_10 (28) = happyShift action_18 +action_10 (37) = happyShift action_19 +action_10 (38) = happyShift action_20 +action_10 (53) = happyShift action_12 +action_10 (55) = happyShift action_21 +action_10 (14) = happyGoto action_13 +action_10 (16) = happyGoto action_14 +action_10 (24) = happyGoto action_15 +action_10 (25) = happyGoto action_16 +action_10 (27) = happyGoto action_17 +action_10 _ = happyFail (happyExpListPerState 10) + +action_11 (53) = happyShift action_12 +action_11 _ = happyFail (happyExpListPerState 11) + +action_12 _ = happyReduce_11 + +action_13 _ = happyReduce_37 + +action_14 _ = happyReduce_34 + +action_15 (32) = happyShift action_63 +action_15 _ = happyReduce_40 + +action_16 _ = happyReduce_43 + +action_17 (56) = happyAccept +action_17 _ = happyFail (happyExpListPerState 17) + +action_18 (28) = happyShift action_18 +action_18 (37) = happyShift action_19 +action_18 (38) = happyShift action_20 +action_18 (45) = happyShift action_24 +action_18 (53) = happyShift action_12 +action_18 (55) = happyShift action_21 +action_18 (14) = happyGoto action_13 +action_18 (16) = happyGoto action_14 +action_18 (24) = happyGoto action_15 +action_18 (25) = happyGoto action_22 +action_18 (26) = happyGoto action_62 +action_18 _ = happyFail (happyExpListPerState 18) + +action_19 _ = happyReduce_36 + +action_20 _ = happyReduce_35 + +action_21 _ = happyReduce_13 + +action_22 _ = happyReduce_42 + +action_23 (56) = happyAccept +action_23 _ = happyFail (happyExpListPerState 23) + +action_24 (53) = happyShift action_12 +action_24 (14) = happyGoto action_27 +action_24 (23) = happyGoto action_61 +action_24 _ = happyFail (happyExpListPerState 24) + +action_25 (56) = happyAccept +action_25 _ = happyFail (happyExpListPerState 25) + +action_26 (56) = happyAccept +action_26 _ = happyFail (happyExpListPerState 26) + +action_27 _ = happyReduce_33 + +action_28 (56) = happyAccept +action_28 _ = happyFail (happyExpListPerState 28) + +action_29 _ = happyReduce_15 + +action_30 _ = happyReduce_18 + +action_31 _ = happyReduce_23 + +action_32 (30) = happyShift action_51 +action_32 (31) = happyShift action_52 +action_32 _ = happyReduce_29 + +action_33 (28) = happyShift action_35 +action_33 (43) = happyShift action_36 +action_33 (48) = happyShift action_39 +action_33 (51) = happyShift action_41 +action_33 (53) = happyShift action_12 +action_33 (54) = happyShift action_43 +action_33 (14) = happyGoto action_29 +action_33 (15) = happyGoto action_30 +action_33 (18) = happyGoto action_31 +action_33 (19) = happyGoto action_53 +action_33 _ = happyReduce_32 + +action_34 (56) = happyAccept +action_34 _ = happyFail (happyExpListPerState 34) + +action_35 (28) = happyShift action_35 +action_35 (43) = happyShift action_36 +action_35 (44) = happyShift action_37 +action_35 (46) = happyShift action_38 +action_35 (48) = happyShift action_39 +action_35 (49) = happyShift action_40 +action_35 (51) = happyShift action_41 +action_35 (52) = happyShift action_42 +action_35 (53) = happyShift action_12 +action_35 (54) = happyShift action_43 +action_35 (14) = happyGoto action_29 +action_35 (15) = happyGoto action_30 +action_35 (18) = happyGoto action_31 +action_35 (19) = happyGoto action_32 +action_35 (20) = happyGoto action_44 +action_35 (21) = happyGoto action_60 +action_35 _ = happyFail (happyExpListPerState 35) + +action_36 _ = happyReduce_17 + +action_37 (53) = happyShift action_12 +action_37 (14) = happyGoto action_49 +action_37 (17) = happyGoto action_59 +action_37 _ = happyFail (happyExpListPerState 37) + +action_38 (28) = happyShift action_35 +action_38 (43) = happyShift action_36 +action_38 (44) = happyShift action_37 +action_38 (46) = happyShift action_38 +action_38 (48) = happyShift action_39 +action_38 (49) = happyShift action_40 +action_38 (51) = happyShift action_41 +action_38 (52) = happyShift action_42 +action_38 (53) = happyShift action_12 +action_38 (54) = happyShift action_43 +action_38 (14) = happyGoto action_29 +action_38 (15) = happyGoto action_30 +action_38 (18) = happyGoto action_31 +action_38 (19) = happyGoto action_32 +action_38 (20) = happyGoto action_58 +action_38 _ = happyFail (happyExpListPerState 38) + +action_39 (28) = happyShift action_57 +action_39 _ = happyFail (happyExpListPerState 39) + +action_40 (53) = happyShift action_12 +action_40 (14) = happyGoto action_49 +action_40 (17) = happyGoto action_56 +action_40 _ = happyFail (happyExpListPerState 40) + +action_41 _ = happyReduce_16 + +action_42 (53) = happyShift action_12 +action_42 (14) = happyGoto action_49 +action_42 (17) = happyGoto action_55 +action_42 _ = happyFail (happyExpListPerState 42) + +action_43 _ = happyReduce_12 + +action_44 (28) = happyShift action_35 +action_44 (35) = happyShift action_54 +action_44 (43) = happyShift action_36 +action_44 (48) = happyShift action_39 +action_44 (51) = happyShift action_41 +action_44 (53) = happyShift action_12 +action_44 (54) = happyShift action_43 +action_44 (14) = happyGoto action_29 +action_44 (15) = happyGoto action_30 +action_44 (18) = happyGoto action_31 +action_44 (19) = happyGoto action_53 +action_44 _ = happyReduce_31 + +action_45 (56) = happyAccept +action_45 _ = happyFail (happyExpListPerState 45) + +action_46 (28) = happyShift action_35 +action_46 (43) = happyShift action_36 +action_46 (48) = happyShift action_39 +action_46 (51) = happyShift action_41 +action_46 (53) = happyShift action_12 +action_46 (54) = happyShift action_43 +action_46 (56) = happyAccept +action_46 (14) = happyGoto action_29 +action_46 (15) = happyGoto action_30 +action_46 (18) = happyGoto action_31 +action_46 (19) = happyGoto action_53 +action_46 _ = happyFail (happyExpListPerState 46) + +action_47 (30) = happyShift action_51 +action_47 (31) = happyShift action_52 +action_47 (56) = happyAccept +action_47 _ = happyFail (happyExpListPerState 47) + +action_48 (56) = happyAccept +action_48 _ = happyFail (happyExpListPerState 48) + +action_49 _ = happyReduce_14 + +action_50 (56) = happyAccept +action_50 _ = happyFail (happyExpListPerState 50) + +action_51 (28) = happyShift action_35 +action_51 (43) = happyShift action_36 +action_51 (51) = happyShift action_41 +action_51 (53) = happyShift action_12 +action_51 (54) = happyShift action_43 +action_51 (14) = happyGoto action_29 +action_51 (15) = happyGoto action_30 +action_51 (18) = happyGoto action_75 +action_51 _ = happyFail (happyExpListPerState 51) + +action_52 (28) = happyShift action_35 +action_52 (43) = happyShift action_36 +action_52 (51) = happyShift action_41 +action_52 (53) = happyShift action_12 +action_52 (54) = happyShift action_43 +action_52 (14) = happyGoto action_29 +action_52 (15) = happyGoto action_30 +action_52 (18) = happyGoto action_74 +action_52 _ = happyFail (happyExpListPerState 52) + +action_53 (30) = happyShift action_51 +action_53 (31) = happyShift action_52 +action_53 _ = happyReduce_27 + +action_54 (28) = happyShift action_18 +action_54 (37) = happyShift action_19 +action_54 (38) = happyShift action_20 +action_54 (45) = happyShift action_24 +action_54 (53) = happyShift action_12 +action_54 (55) = happyShift action_21 +action_54 (14) = happyGoto action_13 +action_54 (16) = happyGoto action_14 +action_54 (24) = happyGoto action_15 +action_54 (25) = happyGoto action_22 +action_54 (26) = happyGoto action_73 +action_54 _ = happyFail (happyExpListPerState 54) + +action_55 (33) = happyShift action_72 +action_55 _ = happyFail (happyExpListPerState 55) + +action_56 (36) = happyShift action_71 +action_56 _ = happyFail (happyExpListPerState 56) + +action_57 (28) = happyShift action_35 +action_57 (43) = happyShift action_36 +action_57 (44) = happyShift action_37 +action_57 (46) = happyShift action_38 +action_57 (48) = happyShift action_39 +action_57 (49) = happyShift action_40 +action_57 (51) = happyShift action_41 +action_57 (52) = happyShift action_42 +action_57 (53) = happyShift action_12 +action_57 (54) = happyShift action_43 +action_57 (14) = happyGoto action_29 +action_57 (15) = happyGoto action_30 +action_57 (18) = happyGoto action_31 +action_57 (19) = happyGoto action_32 +action_57 (20) = happyGoto action_44 +action_57 (21) = happyGoto action_70 +action_57 _ = happyFail (happyExpListPerState 57) + +action_58 (28) = happyShift action_35 +action_58 (43) = happyShift action_36 +action_58 (48) = happyShift action_39 +action_58 (50) = happyShift action_69 +action_58 (51) = happyShift action_41 +action_58 (53) = happyShift action_12 +action_58 (54) = happyShift action_43 +action_58 (14) = happyGoto action_29 +action_58 (15) = happyGoto action_30 +action_58 (18) = happyGoto action_31 +action_58 (19) = happyGoto action_53 +action_58 _ = happyFail (happyExpListPerState 58) + +action_59 (47) = happyShift action_68 +action_59 _ = happyFail (happyExpListPerState 59) + +action_60 (29) = happyShift action_67 +action_60 _ = happyFail (happyExpListPerState 60) + +action_61 (33) = happyShift action_66 +action_61 _ = happyFail (happyExpListPerState 61) + +action_62 (29) = happyShift action_65 +action_62 _ = happyFail (happyExpListPerState 62) + +action_63 (28) = happyShift action_18 +action_63 (37) = happyShift action_19 +action_63 (38) = happyShift action_20 +action_63 (53) = happyShift action_12 +action_63 (55) = happyShift action_21 +action_63 (14) = happyGoto action_13 +action_63 (16) = happyGoto action_14 +action_63 (24) = happyGoto action_15 +action_63 (25) = happyGoto action_64 +action_63 _ = happyFail (happyExpListPerState 63) + +action_64 _ = happyReduce_39 + +action_65 _ = happyReduce_38 + +action_66 (28) = happyShift action_18 +action_66 (37) = happyShift action_19 +action_66 (38) = happyShift action_20 +action_66 (53) = happyShift action_12 +action_66 (55) = happyShift action_21 +action_66 (14) = happyGoto action_13 +action_66 (16) = happyGoto action_14 +action_66 (24) = happyGoto action_15 +action_66 (25) = happyGoto action_16 +action_66 (27) = happyGoto action_81 +action_66 _ = happyFail (happyExpListPerState 66) + +action_67 _ = happyReduce_19 + +action_68 (39) = happyShift action_80 +action_68 _ = happyFail (happyExpListPerState 68) + +action_69 (28) = happyShift action_35 +action_69 (43) = happyShift action_36 +action_69 (44) = happyShift action_37 +action_69 (46) = happyShift action_38 +action_69 (48) = happyShift action_39 +action_69 (49) = happyShift action_40 +action_69 (51) = happyShift action_41 +action_69 (52) = happyShift action_42 +action_69 (53) = happyShift action_12 +action_69 (54) = happyShift action_43 +action_69 (14) = happyGoto action_29 +action_69 (15) = happyGoto action_30 +action_69 (18) = happyGoto action_31 +action_69 (19) = happyGoto action_32 +action_69 (20) = happyGoto action_79 +action_69 _ = happyFail (happyExpListPerState 69) + +action_70 (29) = happyShift action_78 +action_70 _ = happyFail (happyExpListPerState 70) + +action_71 (28) = happyShift action_35 +action_71 (43) = happyShift action_36 +action_71 (44) = happyShift action_37 +action_71 (46) = happyShift action_38 +action_71 (48) = happyShift action_39 +action_71 (49) = happyShift action_40 +action_71 (51) = happyShift action_41 +action_71 (52) = happyShift action_42 +action_71 (53) = happyShift action_12 +action_71 (54) = happyShift action_43 +action_71 (14) = happyGoto action_29 +action_71 (15) = happyGoto action_30 +action_71 (18) = happyGoto action_31 +action_71 (19) = happyGoto action_32 +action_71 (20) = happyGoto action_77 +action_71 _ = happyFail (happyExpListPerState 71) + +action_72 (28) = happyShift action_35 +action_72 (43) = happyShift action_36 +action_72 (44) = happyShift action_37 +action_72 (46) = happyShift action_38 +action_72 (48) = happyShift action_39 +action_72 (49) = happyShift action_40 +action_72 (51) = happyShift action_41 +action_72 (52) = happyShift action_42 +action_72 (53) = happyShift action_12 +action_72 (54) = happyShift action_43 +action_72 (14) = happyGoto action_29 +action_72 (15) = happyGoto action_30 +action_72 (18) = happyGoto action_31 +action_72 (19) = happyGoto action_32 +action_72 (20) = happyGoto action_33 +action_72 (22) = happyGoto action_76 +action_72 _ = happyFail (happyExpListPerState 72) + +action_73 _ = happyReduce_30 + +action_74 _ = happyReduce_21 + +action_75 _ = happyReduce_20 + +action_76 _ = happyReduce_26 + +action_77 (28) = happyShift action_35 +action_77 (43) = happyShift action_36 +action_77 (47) = happyShift action_84 +action_77 (48) = happyShift action_39 +action_77 (51) = happyShift action_41 +action_77 (53) = happyShift action_12 +action_77 (54) = happyShift action_43 +action_77 (14) = happyGoto action_29 +action_77 (15) = happyGoto action_30 +action_77 (18) = happyGoto action_31 +action_77 (19) = happyGoto action_53 +action_77 _ = happyFail (happyExpListPerState 77) + +action_78 _ = happyReduce_22 + +action_79 (28) = happyShift action_35 +action_79 (42) = happyShift action_83 +action_79 (43) = happyShift action_36 +action_79 (48) = happyShift action_39 +action_79 (51) = happyShift action_41 +action_79 (53) = happyShift action_12 +action_79 (54) = happyShift action_43 +action_79 (14) = happyGoto action_29 +action_79 (15) = happyGoto action_30 +action_79 (18) = happyGoto action_31 +action_79 (19) = happyGoto action_53 +action_79 _ = happyFail (happyExpListPerState 79) + +action_80 (28) = happyShift action_35 +action_80 (43) = happyShift action_36 +action_80 (44) = happyShift action_37 +action_80 (46) = happyShift action_38 +action_80 (48) = happyShift action_39 +action_80 (49) = happyShift action_40 +action_80 (51) = happyShift action_41 +action_80 (52) = happyShift action_42 +action_80 (53) = happyShift action_12 +action_80 (54) = happyShift action_43 +action_80 (14) = happyGoto action_29 +action_80 (15) = happyGoto action_30 +action_80 (18) = happyGoto action_31 +action_80 (19) = happyGoto action_32 +action_80 (20) = happyGoto action_82 +action_80 _ = happyFail (happyExpListPerState 80) + +action_81 _ = happyReduce_41 + +action_82 (28) = happyShift action_35 +action_82 (34) = happyShift action_87 +action_82 (43) = happyShift action_36 +action_82 (48) = happyShift action_39 +action_82 (51) = happyShift action_41 +action_82 (53) = happyShift action_12 +action_82 (54) = happyShift action_43 +action_82 (14) = happyGoto action_29 +action_82 (15) = happyGoto action_30 +action_82 (18) = happyGoto action_31 +action_82 (19) = happyGoto action_53 +action_82 _ = happyFail (happyExpListPerState 82) + +action_83 (28) = happyShift action_35 +action_83 (43) = happyShift action_36 +action_83 (44) = happyShift action_37 +action_83 (46) = happyShift action_38 +action_83 (48) = happyShift action_39 +action_83 (49) = happyShift action_40 +action_83 (51) = happyShift action_41 +action_83 (52) = happyShift action_42 +action_83 (53) = happyShift action_12 +action_83 (54) = happyShift action_43 +action_83 (14) = happyGoto action_29 +action_83 (15) = happyGoto action_30 +action_83 (18) = happyGoto action_31 +action_83 (19) = happyGoto action_32 +action_83 (20) = happyGoto action_86 +action_83 _ = happyFail (happyExpListPerState 83) + +action_84 (28) = happyShift action_35 +action_84 (43) = happyShift action_36 +action_84 (44) = happyShift action_37 +action_84 (46) = happyShift action_38 +action_84 (48) = happyShift action_39 +action_84 (49) = happyShift action_40 +action_84 (51) = happyShift action_41 +action_84 (52) = happyShift action_42 +action_84 (53) = happyShift action_12 +action_84 (54) = happyShift action_43 +action_84 (14) = happyGoto action_29 +action_84 (15) = happyGoto action_30 +action_84 (18) = happyGoto action_31 +action_84 (19) = happyGoto action_32 +action_84 (20) = happyGoto action_33 +action_84 (22) = happyGoto action_85 +action_84 _ = happyFail (happyExpListPerState 84) + +action_85 _ = happyReduce_25 + +action_86 (28) = happyShift action_35 +action_86 (43) = happyShift action_36 +action_86 (48) = happyShift action_39 +action_86 (51) = happyShift action_41 +action_86 (53) = happyShift action_12 +action_86 (54) = happyShift action_43 +action_86 (14) = happyGoto action_29 +action_86 (15) = happyGoto action_30 +action_86 (18) = happyGoto action_31 +action_86 (19) = happyGoto action_53 +action_86 _ = happyReduce_24 + +action_87 (28) = happyShift action_35 +action_87 (43) = happyShift action_36 +action_87 (44) = happyShift action_37 +action_87 (46) = happyShift action_38 +action_87 (48) = happyShift action_39 +action_87 (49) = happyShift action_40 +action_87 (51) = happyShift action_41 +action_87 (52) = happyShift action_42 +action_87 (53) = happyShift action_12 +action_87 (54) = happyShift action_43 +action_87 (14) = happyGoto action_29 +action_87 (15) = happyGoto action_30 +action_87 (18) = happyGoto action_31 +action_87 (19) = happyGoto action_32 +action_87 (20) = happyGoto action_88 +action_87 _ = happyFail (happyExpListPerState 87) + +action_88 (28) = happyShift action_35 +action_88 (40) = happyShift action_89 +action_88 (43) = happyShift action_36 +action_88 (48) = happyShift action_39 +action_88 (51) = happyShift action_41 +action_88 (53) = happyShift action_12 +action_88 (54) = happyShift action_43 +action_88 (14) = happyGoto action_29 +action_88 (15) = happyGoto action_30 +action_88 (18) = happyGoto action_31 +action_88 (19) = happyGoto action_53 +action_88 _ = happyFail (happyExpListPerState 88) + +action_89 (41) = happyShift action_90 +action_89 _ = happyFail (happyExpListPerState 89) + +action_90 (28) = happyShift action_35 +action_90 (43) = happyShift action_36 +action_90 (44) = happyShift action_37 +action_90 (46) = happyShift action_38 +action_90 (48) = happyShift action_39 +action_90 (49) = happyShift action_40 +action_90 (51) = happyShift action_41 +action_90 (52) = happyShift action_42 +action_90 (53) = happyShift action_12 +action_90 (54) = happyShift action_43 +action_90 (14) = happyGoto action_29 +action_90 (15) = happyGoto action_30 +action_90 (18) = happyGoto action_31 +action_90 (19) = happyGoto action_32 +action_90 (20) = happyGoto action_33 +action_90 (22) = happyGoto action_91 +action_90 _ = happyFail (happyExpListPerState 90) + +action_91 _ = happyReduce_28 + +happyReduce_11 = happySpecReduce_1 14 happyReduction_11 +happyReduction_11 (HappyTerminal (PT _ (TV happy_var_1))) + = HappyAbsSyn14 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.Ident happy_var_1 + ) +happyReduction_11 _ = notHappyAtAll + +happyReduce_12 = happySpecReduce_1 15 happyReduction_12 +happyReduction_12 (HappyTerminal (PT _ (TI happy_var_1))) + = HappyAbsSyn15 + ((read happy_var_1) :: Integer + ) +happyReduction_12 _ = notHappyAtAll + +happyReduce_13 = happySpecReduce_1 16 happyReduction_13 +happyReduction_13 (HappyTerminal (PT _ (T_UVarIdent happy_var_1))) + = HappyAbsSyn16 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.UVarIdent happy_var_1 + ) +happyReduction_13 _ = notHappyAtAll + +happyReduce_14 = happySpecReduce_1 17 happyReduction_14 +happyReduction_14 (HappyAbsSyn14 happy_var_1) + = HappyAbsSyn17 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.PatternVar happy_var_1 + ) +happyReduction_14 _ = notHappyAtAll + +happyReduce_15 = happySpecReduce_1 18 happyReduction_15 +happyReduction_15 (HappyAbsSyn14 happy_var_1) + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.EVar happy_var_1 + ) +happyReduction_15 _ = notHappyAtAll + +happyReduce_16 = happySpecReduce_1 18 happyReduction_16 +happyReduction_16 _ + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.ETrue + ) + +happyReduce_17 = happySpecReduce_1 18 happyReduction_17 +happyReduction_17 _ + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.EFalse + ) + +happyReduce_18 = happySpecReduce_1 18 happyReduction_18 +happyReduction_18 (HappyAbsSyn15 happy_var_1) + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.ENat happy_var_1 + ) +happyReduction_18 _ = notHappyAtAll + +happyReduce_19 = happySpecReduce_3 18 happyReduction_19 +happyReduction_19 _ + (HappyAbsSyn18 happy_var_2) + _ + = HappyAbsSyn18 + (happy_var_2 + ) +happyReduction_19 _ _ _ = notHappyAtAll + +happyReduce_20 = happySpecReduce_3 19 happyReduction_20 +happyReduction_20 (HappyAbsSyn18 happy_var_3) + _ + (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.EAdd happy_var_1 happy_var_3 + ) +happyReduction_20 _ _ _ = notHappyAtAll + +happyReduce_21 = happySpecReduce_3 19 happyReduction_21 +happyReduction_21 (HappyAbsSyn18 happy_var_3) + _ + (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.ESub happy_var_1 happy_var_3 + ) +happyReduction_21 _ _ _ = notHappyAtAll + +happyReduce_22 = happyReduce 4 19 happyReduction_22 +happyReduction_22 (_ `HappyStk` + (HappyAbsSyn18 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.EIsZero happy_var_3 + ) `HappyStk` happyRest + +happyReduce_23 = happySpecReduce_1 19 happyReduction_23 +happyReduction_23 (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn18 + (happy_var_1 + ) +happyReduction_23 _ = notHappyAtAll + +happyReduce_24 = happyReduce 6 20 happyReduction_24 +happyReduction_24 ((HappyAbsSyn18 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn18 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn18 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.EIf happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest + +happyReduce_25 = happyReduce 6 20 happyReduction_25 +happyReduction_25 ((HappyAbsSyn22 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn18 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn17 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.ELet happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest + +happyReduce_26 = happyReduce 4 20 happyReduction_26 +happyReduction_26 ((HappyAbsSyn22 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn17 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.EAbs happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_27 = happySpecReduce_2 20 happyReduction_27 +happyReduction_27 (HappyAbsSyn18 happy_var_2) + (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.EApp happy_var_1 happy_var_2 + ) +happyReduction_27 _ _ = notHappyAtAll + +happyReduce_28 = happyReduce 10 20 happyReduction_28 +happyReduction_28 ((HappyAbsSyn22 happy_var_10) `HappyStk` + _ `HappyStk` + _ `HappyStk` + (HappyAbsSyn18 happy_var_7) `HappyStk` + _ `HappyStk` + (HappyAbsSyn18 happy_var_5) `HappyStk` + _ `HappyStk` + _ `HappyStk` + (HappyAbsSyn17 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.EFor happy_var_2 happy_var_5 happy_var_7 happy_var_10 + ) `HappyStk` happyRest + +happyReduce_29 = happySpecReduce_1 20 happyReduction_29 +happyReduction_29 (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn18 + (happy_var_1 + ) +happyReduction_29 _ = notHappyAtAll + +happyReduce_30 = happySpecReduce_3 21 happyReduction_30 +happyReduction_30 (HappyAbsSyn24 happy_var_3) + _ + (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn18 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.ETyped happy_var_1 happy_var_3 + ) +happyReduction_30 _ _ _ = notHappyAtAll + +happyReduce_31 = happySpecReduce_1 21 happyReduction_31 +happyReduction_31 (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn18 + (happy_var_1 + ) +happyReduction_31 _ = notHappyAtAll + +happyReduce_32 = happySpecReduce_1 22 happyReduction_32 +happyReduction_32 (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn22 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedExp happy_var_1 + ) +happyReduction_32 _ = notHappyAtAll + +happyReduce_33 = happySpecReduce_1 23 happyReduction_33 +happyReduction_33 (HappyAbsSyn14 happy_var_1) + = HappyAbsSyn23 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.TPatternVar happy_var_1 + ) +happyReduction_33 _ = notHappyAtAll + +happyReduce_34 = happySpecReduce_1 24 happyReduction_34 +happyReduction_34 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn24 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.TUVar happy_var_1 + ) +happyReduction_34 _ = notHappyAtAll + +happyReduce_35 = happySpecReduce_1 24 happyReduction_35 +happyReduction_35 _ + = HappyAbsSyn24 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.TNat + ) + +happyReduce_36 = happySpecReduce_1 24 happyReduction_36 +happyReduction_36 _ + = HappyAbsSyn24 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.TBool + ) + +happyReduce_37 = happySpecReduce_1 24 happyReduction_37 +happyReduction_37 (HappyAbsSyn14 happy_var_1) + = HappyAbsSyn24 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.TVar happy_var_1 + ) +happyReduction_37 _ = notHappyAtAll + +happyReduce_38 = happySpecReduce_3 24 happyReduction_38 +happyReduction_38 _ + (HappyAbsSyn24 happy_var_2) + _ + = HappyAbsSyn24 + (happy_var_2 + ) +happyReduction_38 _ _ _ = notHappyAtAll + +happyReduce_39 = happySpecReduce_3 25 happyReduction_39 +happyReduction_39 (HappyAbsSyn24 happy_var_3) + _ + (HappyAbsSyn24 happy_var_1) + = HappyAbsSyn24 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.TArrow happy_var_1 happy_var_3 + ) +happyReduction_39 _ _ _ = notHappyAtAll + +happyReduce_40 = happySpecReduce_1 25 happyReduction_40 +happyReduction_40 (HappyAbsSyn24 happy_var_1) + = HappyAbsSyn24 + (happy_var_1 + ) +happyReduction_40 _ = notHappyAtAll + +happyReduce_41 = happyReduce 4 26 happyReduction_41 +happyReduction_41 ((HappyAbsSyn27 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn24 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.TForAll happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_42 = happySpecReduce_1 26 happyReduction_42 +happyReduction_42 (HappyAbsSyn24 happy_var_1) + = HappyAbsSyn24 + (happy_var_1 + ) +happyReduction_42 _ = notHappyAtAll + +happyReduce_43 = happySpecReduce_1 27 happyReduction_43 +happyReduction_43 (HappyAbsSyn24 happy_var_1) + = HappyAbsSyn27 + (FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedType happy_var_1 + ) +happyReduction_43 _ = notHappyAtAll + +happyNewToken action sts stk [] = + action 56 56 notHappyAtAll (HappyState action) sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = action i i tk (HappyState action) sts stk tks in + case tk of { + PT _ (TS _ 1) -> cont 28; + PT _ (TS _ 2) -> cont 29; + PT _ (TS _ 3) -> cont 30; + PT _ (TS _ 4) -> cont 31; + PT _ (TS _ 5) -> cont 32; + PT _ (TS _ 6) -> cont 33; + PT _ (TS _ 7) -> cont 34; + PT _ (TS _ 8) -> cont 35; + PT _ (TS _ 9) -> cont 36; + PT _ (TS _ 10) -> cont 37; + PT _ (TS _ 11) -> cont 38; + PT _ (TS _ 12) -> cont 39; + PT _ (TS _ 13) -> cont 40; + PT _ (TS _ 14) -> cont 41; + PT _ (TS _ 15) -> cont 42; + PT _ (TS _ 16) -> cont 43; + PT _ (TS _ 17) -> cont 44; + PT _ (TS _ 18) -> cont 45; + PT _ (TS _ 19) -> cont 46; + PT _ (TS _ 20) -> cont 47; + PT _ (TS _ 21) -> cont 48; + PT _ (TS _ 22) -> cont 49; + PT _ (TS _ 23) -> cont 50; + PT _ (TS _ 24) -> cont 51; + PT _ (TS _ 25) -> cont 52; + PT _ (TV happy_dollar_dollar) -> cont 53; + PT _ (TI happy_dollar_dollar) -> cont 54; + PT _ (T_UVarIdent happy_dollar_dollar) -> cont 55; + _ -> happyError' ((tk:tks), []) + } + +happyError_ explist 56 tk tks = happyError' (tks, explist) +happyError_ explist _ tk tks = happyError' ((tk:tks), explist) + +happyThen :: () => Err a -> (a -> Err b) -> Err b +happyThen = ((>>=)) +happyReturn :: () => a -> Err a +happyReturn = (return) +happyThen1 m k tks = ((>>=)) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> Err a +happyReturn1 = \a tks -> (return) a +happyError' :: () => ([(Token)], [Prelude.String]) -> Err a +happyError' = (\(tokens, _) -> happyError tokens) +pPattern tks = happySomeParser where + happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn17 z -> happyReturn z; _other -> notHappyAtAll }) + +pExp3 tks = happySomeParser where + happySomeParser = happyThen (happyParse action_1 tks) (\x -> case x of {HappyAbsSyn18 z -> happyReturn z; _other -> notHappyAtAll }) + +pExp2 tks = happySomeParser where + happySomeParser = happyThen (happyParse action_2 tks) (\x -> case x of {HappyAbsSyn18 z -> happyReturn z; _other -> notHappyAtAll }) + +pExp1 tks = happySomeParser where + happySomeParser = happyThen (happyParse action_3 tks) (\x -> case x of {HappyAbsSyn18 z -> happyReturn z; _other -> notHappyAtAll }) + +pExp tks = happySomeParser where + happySomeParser = happyThen (happyParse action_4 tks) (\x -> case x of {HappyAbsSyn18 z -> happyReturn z; _other -> notHappyAtAll }) + +pScopedExp tks = happySomeParser where + happySomeParser = happyThen (happyParse action_5 tks) (\x -> case x of {HappyAbsSyn22 z -> happyReturn z; _other -> notHappyAtAll }) + +pTypePattern tks = happySomeParser where + happySomeParser = happyThen (happyParse action_6 tks) (\x -> case x of {HappyAbsSyn23 z -> happyReturn z; _other -> notHappyAtAll }) + +pType2 tks = happySomeParser where + happySomeParser = happyThen (happyParse action_7 tks) (\x -> case x of {HappyAbsSyn24 z -> happyReturn z; _other -> notHappyAtAll }) + +pType1 tks = happySomeParser where + happySomeParser = happyThen (happyParse action_8 tks) (\x -> case x of {HappyAbsSyn24 z -> happyReturn z; _other -> notHappyAtAll }) + +pType tks = happySomeParser where + happySomeParser = happyThen (happyParse action_9 tks) (\x -> case x of {HappyAbsSyn24 z -> happyReturn z; _other -> notHappyAtAll }) + +pScopedType tks = happySomeParser where + happySomeParser = happyThen (happyParse action_10 tks) (\x -> case x of {HappyAbsSyn27 z -> happyReturn z; _other -> notHappyAtAll }) + +happySeq = happyDontSeq + + +type Err = Either String + +happyError :: [Token] -> Err a +happyError ts = Left $ + "syntax error at " ++ tokenPos ts ++ + case ts of + [] -> [] + [Err _] -> " due to lexer error" + t:_ -> " before `" ++ (prToken t) ++ "'" + +myLexer :: String -> [Token] +myLexer = tokens +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +data Happy_IntList = HappyCons Prelude.Int Happy_IntList + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is ERROR_TOK, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +indexShortOffAddr arr off = arr Happy_Data_Array.! off + + +{-# INLINE happyLt #-} +happyLt x y = (x Prelude.< y) + + + + + + +readArrayBit arr bit = + Bits.testBit (indexShortOffAddr arr (bit `Prelude.div` 16)) (bit `Prelude.mod` 16) + + + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + + + +newtype HappyState b c = HappyState + (Prelude.Int -> -- token number + Prelude.Int -> -- token number (yes, again) + b -> -- token semantic value + HappyState b c -> -- current state + [HappyState b c] -> -- state stack + c) + + + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state (1) tk st sts stk@(x `HappyStk` _) = + let i = (case x of { HappyErrorToken (i) -> i }) in +-- trace "shifting the error token" $ + new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk + = action nt j tk st ((st):(sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Prelude.- ((1) :: Prelude.Int)) sts of + sts1@(((st1@(HappyState (action))):(_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (action nt j tk st1 sts1 r) + +happyMonadReduce k nt fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + case happyDrop k ((st):(sts)) of + sts1@(((st1@(HappyState (action))):(_))) -> + let drop_stk = happyDropStk k stk in + happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) + +happyMonad2Reduce k nt fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + case happyDrop k ((st):(sts)) of + sts1@(((st1@(HappyState (action))):(_))) -> + let drop_stk = happyDropStk k stk + + + + + + _ = nt :: Prelude.Int + new_state = action + + in + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + +happyDrop (0) l = l +happyDrop n ((_):(t)) = happyDrop (n Prelude.- ((1) :: Prelude.Int)) t + +happyDropStk (0) l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Prelude.- ((1)::Prelude.Int)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + + + + + + + + +happyGoto action j tk st = action j j tk (HappyState action) + + +----------------------------------------------------------------------------- +-- Error recovery (ERROR_TOK is the error token) + +-- parse error if we are in recovery and we fail again +happyFail explist (1) tk old_st _ stk@(x `HappyStk` _) = + let i = (case x of { HappyErrorToken (i) -> i }) in +-- trace "failing" $ + happyError_ explist i tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail explist i tk (HappyState (action)) sts stk = +-- trace "entering error recovery" $ + action (1) (1) tk (HappyState (action)) sts ((HappyErrorToken (i)) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = Prelude.error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + + + + + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `Prelude.seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + + + + + + + + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src/FreeFoilTypecheck/HindleyMilner/Parser/Par.y b/src/FreeFoilTypecheck/HindleyMilner/Parser/Par.y new file mode 100644 index 0000000..e773054 --- /dev/null +++ b/src/FreeFoilTypecheck/HindleyMilner/Parser/Par.y @@ -0,0 +1,165 @@ +-- -*- haskell -*- File generated by the BNF Converter (bnfc 2.9.5). + +-- Parser definition for use with Happy +{ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module FreeFoilTypecheck.HindleyMilner.Parser.Par + ( happyError + , myLexer + , pPattern + , pExp3 + , pExp2 + , pExp1 + , pExp + , pScopedExp + , pTypePattern + , pType2 + , pType1 + , pType + , pScopedType + ) where + +import Prelude + +import qualified FreeFoilTypecheck.HindleyMilner.Parser.Abs +import FreeFoilTypecheck.HindleyMilner.Parser.Lex + +} + +%name pPattern Pattern +%name pExp3 Exp3 +%name pExp2 Exp2 +%name pExp1 Exp1 +%name pExp Exp +%name pScopedExp ScopedExp +%name pTypePattern TypePattern +%name pType2 Type2 +%name pType1 Type1 +%name pType Type +%name pScopedType ScopedType +-- no lexer declaration +%monad { Err } { (>>=) } { return } +%tokentype {Token} +%token + '(' { PT _ (TS _ 1) } + ')' { PT _ (TS _ 2) } + '+' { PT _ (TS _ 3) } + '-' { PT _ (TS _ 4) } + '->' { PT _ (TS _ 5) } + '.' { PT _ (TS _ 6) } + '..' { PT _ (TS _ 7) } + ':' { PT _ (TS _ 8) } + '=' { PT _ (TS _ 9) } + 'Bool' { PT _ (TS _ 10) } + 'Nat' { PT _ (TS _ 11) } + '[' { PT _ (TS _ 12) } + ']' { PT _ (TS _ 13) } + 'do' { PT _ (TS _ 14) } + 'else' { PT _ (TS _ 15) } + 'false' { PT _ (TS _ 16) } + 'for' { PT _ (TS _ 17) } + 'forall' { PT _ (TS _ 18) } + 'if' { PT _ (TS _ 19) } + 'in' { PT _ (TS _ 20) } + 'iszero' { PT _ (TS _ 21) } + 'let' { PT _ (TS _ 22) } + 'then' { PT _ (TS _ 23) } + 'true' { PT _ (TS _ 24) } + 'λ' { PT _ (TS _ 25) } + L_Ident { PT _ (TV $$) } + L_integ { PT _ (TI $$) } + L_UVarIdent { PT _ (T_UVarIdent $$) } + +%% + +Ident :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.Ident } +Ident : L_Ident { FreeFoilTypecheck.HindleyMilner.Parser.Abs.Ident $1 } + +Integer :: { Integer } +Integer : L_integ { (read $1) :: Integer } + +UVarIdent :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.UVarIdent } +UVarIdent : L_UVarIdent { FreeFoilTypecheck.HindleyMilner.Parser.Abs.UVarIdent $1 } + +Pattern :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.Pattern } +Pattern + : Ident { FreeFoilTypecheck.HindleyMilner.Parser.Abs.PatternVar $1 } + +Exp3 :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.Exp } +Exp3 + : Ident { FreeFoilTypecheck.HindleyMilner.Parser.Abs.EVar $1 } + | 'true' { FreeFoilTypecheck.HindleyMilner.Parser.Abs.ETrue } + | 'false' { FreeFoilTypecheck.HindleyMilner.Parser.Abs.EFalse } + | Integer { FreeFoilTypecheck.HindleyMilner.Parser.Abs.ENat $1 } + | '(' Exp ')' { $2 } + +Exp2 :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.Exp } +Exp2 + : Exp2 '+' Exp3 { FreeFoilTypecheck.HindleyMilner.Parser.Abs.EAdd $1 $3 } + | Exp2 '-' Exp3 { FreeFoilTypecheck.HindleyMilner.Parser.Abs.ESub $1 $3 } + | 'iszero' '(' Exp ')' { FreeFoilTypecheck.HindleyMilner.Parser.Abs.EIsZero $3 } + | Exp3 { $1 } + +Exp1 :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.Exp } +Exp1 + : 'if' Exp1 'then' Exp1 'else' Exp1 { FreeFoilTypecheck.HindleyMilner.Parser.Abs.EIf $2 $4 $6 } + | 'let' Pattern '=' Exp1 'in' ScopedExp { FreeFoilTypecheck.HindleyMilner.Parser.Abs.ELet $2 $4 $6 } + | 'λ' Pattern '.' ScopedExp { FreeFoilTypecheck.HindleyMilner.Parser.Abs.EAbs $2 $4 } + | Exp1 Exp2 { FreeFoilTypecheck.HindleyMilner.Parser.Abs.EApp $1 $2 } + | 'for' Pattern 'in' '[' Exp1 '..' Exp1 ']' 'do' ScopedExp { FreeFoilTypecheck.HindleyMilner.Parser.Abs.EFor $2 $5 $7 $10 } + | Exp2 { $1 } + +Exp :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.Exp } +Exp + : Exp1 ':' Type { FreeFoilTypecheck.HindleyMilner.Parser.Abs.ETyped $1 $3 } + | Exp1 { $1 } + +ScopedExp :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedExp } +ScopedExp + : Exp1 { FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedExp $1 } + +TypePattern :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.TypePattern } +TypePattern + : Ident { FreeFoilTypecheck.HindleyMilner.Parser.Abs.TPatternVar $1 } + +Type2 :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.Type } +Type2 + : UVarIdent { FreeFoilTypecheck.HindleyMilner.Parser.Abs.TUVar $1 } + | 'Nat' { FreeFoilTypecheck.HindleyMilner.Parser.Abs.TNat } + | 'Bool' { FreeFoilTypecheck.HindleyMilner.Parser.Abs.TBool } + | Ident { FreeFoilTypecheck.HindleyMilner.Parser.Abs.TVar $1 } + | '(' Type ')' { $2 } + +Type1 :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.Type } +Type1 + : Type2 '->' Type1 { FreeFoilTypecheck.HindleyMilner.Parser.Abs.TArrow $1 $3 } + | Type2 { $1 } + +Type :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.Type } +Type + : 'forall' TypePattern '.' ScopedType { FreeFoilTypecheck.HindleyMilner.Parser.Abs.TForAll $2 $4 } + | Type1 { $1 } + +ScopedType :: { FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedType } +ScopedType + : Type1 { FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedType $1 } + +{ + +type Err = Either String + +happyError :: [Token] -> Err a +happyError ts = Left $ + "syntax error at " ++ tokenPos ts ++ + case ts of + [] -> [] + [Err _] -> " due to lexer error" + t:_ -> " before `" ++ (prToken t) ++ "'" + +myLexer :: String -> [Token] +myLexer = tokens + +} + diff --git a/src/FreeFoilTypecheck/HindleyMilner/Parser/Print.hs b/src/FreeFoilTypecheck/HindleyMilner/Parser/Print.hs new file mode 100644 index 0000000..baf5924 --- /dev/null +++ b/src/FreeFoilTypecheck/HindleyMilner/Parser/Print.hs @@ -0,0 +1,183 @@ +-- File generated by the BNF Converter (bnfc 2.9.5). + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +#if __GLASGOW_HASKELL__ <= 708 +{-# LANGUAGE OverlappingInstances #-} +#endif + +-- | Pretty-printer for FreeFoilTypecheck. + +module FreeFoilTypecheck.HindleyMilner.Parser.Print where + +import Prelude + ( ($), (.) + , Bool(..), (==), (<) + , Int, Integer, Double, (+), (-), (*) + , String, (++) + , ShowS, showChar, showString + , all, elem, foldr, id, map, null, replicate, shows, span + ) +import Data.Char ( Char, isSpace ) +import qualified FreeFoilTypecheck.HindleyMilner.Parser.Abs + +-- | The top-level printing method. + +printTree :: Print a => a -> String +printTree = render . prt 0 + +type Doc = [ShowS] -> [ShowS] + +doc :: ShowS -> Doc +doc = (:) + +render :: Doc -> String +render d = rend 0 False (map ($ "") $ d []) "" + where + rend + :: Int -- ^ Indentation level. + -> Bool -- ^ Pending indentation to be output before next character? + -> [String] + -> ShowS + rend i p = \case + "[" :ts -> char '[' . rend i False ts + "(" :ts -> char '(' . rend i False ts + "{" :ts -> onNewLine i p . showChar '{' . new (i+1) ts + "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts + "}" :ts -> onNewLine (i-1) p . showChar '}' . new (i-1) ts + [";"] -> char ';' + ";" :ts -> char ';' . new i ts + t : ts@(s:_) | closingOrPunctuation s + -> pending . showString t . rend i False ts + t :ts -> pending . space t . rend i False ts + [] -> id + where + -- Output character after pending indentation. + char :: Char -> ShowS + char c = pending . showChar c + + -- Output pending indentation. + pending :: ShowS + pending = if p then indent i else id + + -- Indentation (spaces) for given indentation level. + indent :: Int -> ShowS + indent i = replicateS (2*i) (showChar ' ') + + -- Continue rendering in new line with new indentation. + new :: Int -> [String] -> ShowS + new j ts = showChar '\n' . rend j True ts + + -- Make sure we are on a fresh line. + onNewLine :: Int -> Bool -> ShowS + onNewLine i p = (if p then id else showChar '\n') . indent i + + -- Separate given string from following text by a space (if needed). + space :: String -> ShowS + space t s = + case (all isSpace t, null spc, null rest) of + (True , _ , True ) -> [] -- remove trailing space + (False, _ , True ) -> t -- remove trailing space + (False, True, False) -> t ++ ' ' : s -- add space if none + _ -> t ++ s + where + (spc, rest) = span isSpace s + + closingOrPunctuation :: String -> Bool + closingOrPunctuation [c] = c `elem` closerOrPunct + closingOrPunctuation _ = False + + closerOrPunct :: String + closerOrPunct = ")],;" + +parenth :: Doc -> Doc +parenth ss = doc (showChar '(') . ss . doc (showChar ')') + +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +concatD :: [Doc] -> Doc +concatD = foldr (.) id + +replicateS :: Int -> ShowS -> ShowS +replicateS n f = concatS (replicate n f) + +-- | The printer class does the job. + +class Print a where + prt :: Int -> a -> Doc + +instance {-# OVERLAPPABLE #-} Print a => Print [a] where + prt i = concatD . map (prt i) + +instance Print Char where + prt _ c = doc (showChar '\'' . mkEsc '\'' c . showChar '\'') + +instance Print String where + prt _ = printString + +printString :: String -> Doc +printString s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') + +mkEsc :: Char -> Char -> ShowS +mkEsc q = \case + s | s == q -> showChar '\\' . showChar s + '\\' -> showString "\\\\" + '\n' -> showString "\\n" + '\t' -> showString "\\t" + s -> showChar s + +prPrec :: Int -> Int -> Doc -> Doc +prPrec i j = if j < i then parenth else id + +instance Print Integer where + prt _ x = doc (shows x) + +instance Print Double where + prt _ x = doc (shows x) + +instance Print FreeFoilTypecheck.HindleyMilner.Parser.Abs.Ident where + prt _ (FreeFoilTypecheck.HindleyMilner.Parser.Abs.Ident i) = doc $ showString i +instance Print FreeFoilTypecheck.HindleyMilner.Parser.Abs.UVarIdent where + prt _ (FreeFoilTypecheck.HindleyMilner.Parser.Abs.UVarIdent i) = doc $ showString i +instance Print FreeFoilTypecheck.HindleyMilner.Parser.Abs.Pattern where + prt i = \case + FreeFoilTypecheck.HindleyMilner.Parser.Abs.PatternVar id_ -> prPrec i 0 (concatD [prt 0 id_]) + +instance Print FreeFoilTypecheck.HindleyMilner.Parser.Abs.Exp where + prt i = \case + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EVar id_ -> prPrec i 3 (concatD [prt 0 id_]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ETrue -> prPrec i 3 (concatD [doc (showString "true")]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EFalse -> prPrec i 3 (concatD [doc (showString "false")]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ENat n -> prPrec i 3 (concatD [prt 0 n]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EAdd exp1 exp2 -> prPrec i 2 (concatD [prt 2 exp1, doc (showString "+"), prt 3 exp2]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ESub exp1 exp2 -> prPrec i 2 (concatD [prt 2 exp1, doc (showString "-"), prt 3 exp2]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EIf exp1 exp2 exp3 -> prPrec i 1 (concatD [doc (showString "if"), prt 1 exp1, doc (showString "then"), prt 1 exp2, doc (showString "else"), prt 1 exp3]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EIsZero exp -> prPrec i 2 (concatD [doc (showString "iszero"), doc (showString "("), prt 0 exp, doc (showString ")")]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ETyped exp type_ -> prPrec i 0 (concatD [prt 1 exp, doc (showString ":"), prt 0 type_]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ELet pattern_ exp scopedexp -> prPrec i 1 (concatD [doc (showString "let"), prt 0 pattern_, doc (showString "="), prt 1 exp, doc (showString "in"), prt 0 scopedexp]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EAbs pattern_ scopedexp -> prPrec i 1 (concatD [doc (showString "\955"), prt 0 pattern_, doc (showString "."), prt 0 scopedexp]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EApp exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, prt 2 exp2]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EFor pattern_ exp1 exp2 scopedexp -> prPrec i 1 (concatD [doc (showString "for"), prt 0 pattern_, doc (showString "in"), doc (showString "["), prt 1 exp1, doc (showString ".."), prt 1 exp2, doc (showString "]"), doc (showString "do"), prt 0 scopedexp]) + +instance Print FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedExp where + prt i = \case + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedExp exp -> prPrec i 0 (concatD [prt 1 exp]) + +instance Print FreeFoilTypecheck.HindleyMilner.Parser.Abs.TypePattern where + prt i = \case + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TPatternVar id_ -> prPrec i 0 (concatD [prt 0 id_]) + +instance Print FreeFoilTypecheck.HindleyMilner.Parser.Abs.Type where + prt i = \case + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TUVar uvarident -> prPrec i 2 (concatD [prt 0 uvarident]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TNat -> prPrec i 2 (concatD [doc (showString "Nat")]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TBool -> prPrec i 2 (concatD [doc (showString "Bool")]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TArrow type_1 type_2 -> prPrec i 1 (concatD [prt 2 type_1, doc (showString "->"), prt 1 type_2]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TVar id_ -> prPrec i 2 (concatD [prt 0 id_]) + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TForAll typepattern scopedtype -> prPrec i 0 (concatD [doc (showString "forall"), prt 0 typepattern, doc (showString "."), prt 0 scopedtype]) + +instance Print FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedType where + prt i = \case + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedType type_ -> prPrec i 0 (concatD [prt 1 type_]) diff --git a/src/FreeFoilTypecheck/HindleyMilner/Parser/Skel.hs b/src/FreeFoilTypecheck/HindleyMilner/Parser/Skel.hs new file mode 100644 index 0000000..299d1e1 --- /dev/null +++ b/src/FreeFoilTypecheck/HindleyMilner/Parser/Skel.hs @@ -0,0 +1,65 @@ +-- File generated by the BNF Converter (bnfc 2.9.5). + +-- Templates for pattern matching on abstract syntax + +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +module FreeFoilTypecheck.HindleyMilner.Parser.Skel where + +import Prelude (($), Either(..), String, (++), Show, show) +import qualified FreeFoilTypecheck.HindleyMilner.Parser.Abs + +type Err = Either String +type Result = Err String + +failure :: Show a => a -> Result +failure x = Left $ "Undefined case: " ++ show x + +transIdent :: FreeFoilTypecheck.HindleyMilner.Parser.Abs.Ident -> Result +transIdent x = case x of + FreeFoilTypecheck.HindleyMilner.Parser.Abs.Ident string -> failure x + +transUVarIdent :: FreeFoilTypecheck.HindleyMilner.Parser.Abs.UVarIdent -> Result +transUVarIdent x = case x of + FreeFoilTypecheck.HindleyMilner.Parser.Abs.UVarIdent string -> failure x + +transPattern :: FreeFoilTypecheck.HindleyMilner.Parser.Abs.Pattern -> Result +transPattern x = case x of + FreeFoilTypecheck.HindleyMilner.Parser.Abs.PatternVar ident -> failure x + +transExp :: FreeFoilTypecheck.HindleyMilner.Parser.Abs.Exp -> Result +transExp x = case x of + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EVar ident -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ETrue -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EFalse -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ENat integer -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EAdd exp1 exp2 -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ESub exp1 exp2 -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EIf exp1 exp2 exp3 -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EIsZero exp -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ETyped exp type_ -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ELet pattern_ exp scopedexp -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EAbs pattern_ scopedexp -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EApp exp1 exp2 -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.EFor pattern_ exp1 exp2 scopedexp -> failure x + +transScopedExp :: FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedExp -> Result +transScopedExp x = case x of + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedExp exp -> failure x + +transTypePattern :: FreeFoilTypecheck.HindleyMilner.Parser.Abs.TypePattern -> Result +transTypePattern x = case x of + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TPatternVar ident -> failure x + +transType :: FreeFoilTypecheck.HindleyMilner.Parser.Abs.Type -> Result +transType x = case x of + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TUVar uvarident -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TNat -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TBool -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TArrow type_1 type_2 -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TVar ident -> failure x + FreeFoilTypecheck.HindleyMilner.Parser.Abs.TForAll typepattern scopedtype -> failure x + +transScopedType :: FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedType -> Result +transScopedType x = case x of + FreeFoilTypecheck.HindleyMilner.Parser.Abs.ScopedType type_ -> failure x diff --git a/src/FreeFoilTypecheck/HindleyMilner/Parser/Test.hs b/src/FreeFoilTypecheck/HindleyMilner/Parser/Test.hs new file mode 100644 index 0000000..4e1bdc4 --- /dev/null +++ b/src/FreeFoilTypecheck/HindleyMilner/Parser/Test.hs @@ -0,0 +1,76 @@ +-- File generated by the BNF Converter (bnfc 2.9.5). + +-- | Program to test parser. + +module Main where + +import Prelude + ( ($), (.) + , Either(..) + , Int, (>) + , String, (++), concat, unlines + , Show, show + , IO, (>>), (>>=), mapM_, putStrLn + , FilePath + , getContents, readFile + ) +import System.Environment ( getArgs ) +import System.Exit ( exitFailure ) +import Control.Monad ( when ) + +import FreeFoilTypecheck.HindleyMilner.Parser.Abs () +import FreeFoilTypecheck.HindleyMilner.Parser.Lex ( Token, mkPosToken ) +import FreeFoilTypecheck.HindleyMilner.Parser.Par ( pPattern, myLexer ) +import FreeFoilTypecheck.HindleyMilner.Parser.Print ( Print, printTree ) +import FreeFoilTypecheck.HindleyMilner.Parser.Skel () + +type Err = Either String +type ParseFun a = [Token] -> Err a +type Verbosity = Int + +putStrV :: Verbosity -> String -> IO () +putStrV v s = when (v > 1) $ putStrLn s + +runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO () +runFile v p f = putStrLn f >> readFile f >>= run v p + +run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO () +run v p s = + case p ts of + Left err -> do + putStrLn "\nParse Failed...\n" + putStrV v "Tokens:" + mapM_ (putStrV v . showPosToken . mkPosToken) ts + putStrLn err + exitFailure + Right tree -> do + putStrLn "\nParse Successful!" + showTree v tree + where + ts = myLexer s + showPosToken ((l,c),t) = concat [ show l, ":", show c, "\t", show t ] + +showTree :: (Show a, Print a) => Int -> a -> IO () +showTree v tree = do + putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree + putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree + +usage :: IO () +usage = do + putStrLn $ unlines + [ "usage: Call with one of the following argument combinations:" + , " --help Display this help message." + , " (no arguments) Parse stdin verbosely." + , " (files) Parse content of files verbosely." + , " -s (files) Silent mode. Parse content of files silently." + ] + +main :: IO () +main = do + args <- getArgs + case args of + ["--help"] -> usage + [] -> getContents >>= run 2 pPattern + "-s":fs -> mapM_ (runFile 0 pPattern) fs + fs -> mapM_ (runFile 2 pPattern) fs + diff --git a/src/FreeFoilTypecheck/HindleyMilner/Syntax.hs b/src/FreeFoilTypecheck/HindleyMilner/Syntax.hs new file mode 100644 index 0000000..c9bb6c4 --- /dev/null +++ b/src/FreeFoilTypecheck/HindleyMilner/Syntax.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} + +module FreeFoilTypecheck.HindleyMilner.Syntax where + +import qualified Control.Monad.Foil as Foil +import Control.Monad.Foil.TH +import Control.Monad.Free.Foil +import Control.Monad.Free.Foil.TH +import Data.Bifunctor.TH +import Data.Map (Map) +import qualified Data.Map as Map +import Data.String (IsString (..)) +import qualified FreeFoilTypecheck.HindleyMilner.Parser.Abs as Raw +import qualified FreeFoilTypecheck.HindleyMilner.Parser.Par as Raw +import qualified FreeFoilTypecheck.HindleyMilner.Parser.Print as Raw + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> :set -XDataKinds +-- >>> import qualified Control.Monad.Foil as Foil +-- >>> import Control.Monad.Free.Foil +-- >>> import Data.String (fromString) + +-- * Generated code (expressions) + +-- ** Signature + +mkSignature ''Raw.Exp ''Raw.Ident ''Raw.ScopedExp ''Raw.Pattern +deriveZipMatch ''ExpSig +deriveBifunctor ''ExpSig +deriveBifoldable ''ExpSig +deriveBitraversable ''ExpSig + +-- ** Pattern synonyms + +mkPatternSynonyms ''ExpSig + +{-# COMPLETE Var, ETrue, EFalse, ENat, EAdd, ESub, EIf, EIsZero, ETyped, ELet, EAbs, EApp, EFor #-} + +-- ** Conversion helpers + +mkConvertToFreeFoil ''Raw.Exp ''Raw.Ident ''Raw.ScopedExp ''Raw.Pattern +mkConvertFromFreeFoil ''Raw.Exp ''Raw.Ident ''Raw.ScopedExp ''Raw.Pattern + +-- ** Scope-safe patterns + +mkFoilPattern ''Raw.Ident ''Raw.Pattern +deriveCoSinkable ''Raw.Ident ''Raw.Pattern +mkToFoilPattern ''Raw.Ident ''Raw.Pattern +mkFromFoilPattern ''Raw.Ident ''Raw.Pattern + +-- * Generated code (types) + +-- ** Signature + +mkSignature ''Raw.Type ''Raw.Ident ''Raw.ScopedType ''Raw.TypePattern +deriveZipMatch ''TypeSig +deriveBifunctor ''TypeSig +deriveBifoldable ''TypeSig +deriveBitraversable ''TypeSig + +-- ** Pattern synonyms + +mkPatternSynonyms ''TypeSig + +{-# COMPLETE Var, TUVar, TNat, TBool, TArrow, TForAll #-} + +-- ** Conversion helpers + +mkConvertToFreeFoil ''Raw.Type ''Raw.Ident ''Raw.ScopedType ''Raw.TypePattern +mkConvertFromFreeFoil ''Raw.Type ''Raw.Ident ''Raw.ScopedType ''Raw.TypePattern + +-- ** Scope-safe type patterns + +mkFoilPattern ''Raw.Ident ''Raw.TypePattern +deriveCoSinkable ''Raw.Ident ''Raw.TypePattern +mkToFoilPattern ''Raw.Ident ''Raw.TypePattern +mkFromFoilPattern ''Raw.Ident ''Raw.TypePattern + +instance Foil.UnifiablePattern FoilTypePattern where + unifyPatterns (FoilTPatternVar x) (FoilTPatternVar y) = Foil.unifyNameBinders x y + +-- * User-defined code + +type Exp n = AST FoilPattern ExpSig n + +type Type n = AST FoilTypePattern TypeSig n + +type Type' = Type Foil.VoidS + +-- ** Conversion helpers (expressions) + +-- | Convert 'Raw.Exp' into a scope-safe expression. +-- This is a special case of 'convertToAST'. +toExp :: (Foil.Distinct n) => Foil.Scope n -> Map Raw.Ident (Foil.Name n) -> Raw.Exp -> AST FoilPattern ExpSig n +toExp = convertToAST convertToExpSig toFoilPattern getExpFromScopedExp + +-- | Convert 'Raw.Exp' into a closed scope-safe expression. +-- This is a special case of 'toExp'. +toExpClosed :: Raw.Exp -> Exp Foil.VoidS +toExpClosed = toExp Foil.emptyScope Map.empty + +-- | Convert a scope-safe representation back into 'Raw.Exp'. +-- This is a special case of 'convertFromAST'. +-- +-- 'Raw.Ident' names are generated based on the raw identifiers in the underlying foil representation. +-- +-- This function does not recover location information for variables, patterns, or scoped terms. +fromExp :: Exp n -> Raw.Exp +fromExp = + convertFromAST + convertFromExpSig + Raw.EVar + (fromFoilPattern mkIdent) + Raw.ScopedExp + (\n -> Raw.Ident ("x" ++ show n)) + where + mkIdent n = Raw.Ident ("x" ++ show n) + +-- | Parse scope-safe terms via raw representation. +-- +-- >>> fromString "let x = 2 + 2 in let y = x - 1 in let x = 3 in y + x + y" :: Exp Foil.VoidS +-- let x0 = 2 + 2 in let x1 = x0 - 1 in let x2 = 3 in x1 + x2 + x1 +instance IsString (Exp Foil.VoidS) where + fromString input = case Raw.pExp (Raw.myLexer input) of + Left err -> error ("could not parse expression: " <> input <> "\n " <> err) + Right term -> toExpClosed term + +-- | Pretty-print scope-safe terms via"λ" Ident ":" Type "." Exp1 raw representation. +instance Show (Exp n) where + show = Raw.printTree . fromExp + +-- ** Conversion helpers (types) + +-- | Convert 'Raw.Exp' into a scope-safe expression. +-- This is a special case of 'convertToAST'. +toType :: (Foil.Distinct n) => Foil.Scope n -> Map Raw.Ident (Foil.Name n) -> Raw.Type -> AST FoilTypePattern TypeSig n +toType = convertToAST convertToTypeSig toFoilTypePattern getTypeFromScopedType + +-- | Convert 'Raw.Type' into a closed scope-safe expression. +-- This is a special case of 'toType'. +toTypeClosed :: Raw.Type -> Type Foil.VoidS +toTypeClosed = toType Foil.emptyScope Map.empty + +-- | Convert a scope-safe representation back into 'Raw.Type'. +-- This is a special case of 'convertFromAST'. +-- +-- 'Raw.Ident' names are generated based on the raw identifiers in the underlying foil representation. +-- +-- This function does not recover location information for variables, patterns, or scoped terms. +fromType :: Type n -> Raw.Type +fromType = + convertFromAST + convertFromTypeSig + Raw.TVar + (fromFoilTypePattern mkIdent) + Raw.ScopedType + (\n -> Raw.Ident ("x" ++ show n)) + where + mkIdent n = Raw.Ident ("x" ++ show n) + +-- | Parse scope-safe terms via raw representation. +-- +-- TODO: fix this example +-- -- >>> fromString "let x = 2 + 2 in let y = x - 1 in let x = 3 in y + x + y" :: Type Foil.VoidS +-- -- let x0 = 2 + 2 in let x1 = x0 - 1 in let x2 = 3 in x1 + x2 + x1 +instance IsString (Type Foil.VoidS) where + fromString input = case Raw.pType (Raw.myLexer input) of + Left err -> error ("could not parse expression: " <> input <> "\n " <> err) + Right term -> toTypeClosed term + +-- | Pretty-print scope-safe terms via"λ" Ident ":" Type "." Type1 raw representation. +instance Show (Type n) where + show = Raw.printTree . fromType + +instance Eq (Type Foil.VoidS) where + (==) = alphaEquiv Foil.emptyScope diff --git a/src/FreeFoilTypecheck/HindleyMilner/Typecheck.hs b/src/FreeFoilTypecheck/HindleyMilner/Typecheck.hs new file mode 100644 index 0000000..dea0b3e --- /dev/null +++ b/src/FreeFoilTypecheck/HindleyMilner/Typecheck.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-simplifiable-class-constraints #-} + +module FreeFoilTypecheck.HindleyMilner.Typecheck where + +-- import Control.Applicative (Const) +import Control.Monad (ap) +import qualified Control.Monad.Foil as Foil +import qualified Control.Monad.Foil as FreeFoil +import qualified Control.Monad.Foil.Internal as Foil +import qualified Control.Monad.Free.Foil as FreeFoil +import Data.Bifunctor +import qualified Data.Foldable as F +import qualified Data.IntMap as IntMap +import qualified FreeFoilTypecheck.HindleyMilner.Parser.Abs as Raw +import FreeFoilTypecheck.HindleyMilner.Syntax + +-- $setup +-- >>> :set -XOverloadedStrings + +-- >>> inferTypeNewClosed "λx. x" +-- Right ?u0 -> ?u0 +-- >>> inferTypeNewClosed "λx. x + 1" +-- Right Nat -> Nat +-- >>> inferTypeNewClosed "let f = (λx. λy. let g = x y in g) in f (λz. z) 0" +-- Right Nat +-- >>> inferTypeNewClosed "let twice = (λt. (λx. (t (t x)))) in let add2 = (λx. x + 2) in let bool2int = (λb. if b then 1 else 0) in let not = (λb. if b then false else true) in (twice add2) (bool2int ((twice not) true))" +-- Right Nat +inferTypeNewClosed :: Exp Foil.VoidS -> Either String Type' +inferTypeNewClosed expr = do + (type', TypingContext constrs substs _ _) <- runTypeCheck (reconstructType expr) (TypingContext [] [] Foil.emptyNameMap 0) + substs' <- unify (map (applySubstsToConstraint substs) constrs) + return (applySubstsToType substs' type') + +type Constraint = (Type', Type') + +type USubst n = (Raw.UVarIdent, Type n) + +type USubst' = USubst Foil.VoidS + +unify1 :: Constraint -> Either String [USubst'] +unify1 c = + case c of + -- Case for unification variables + (TUVar x, r) -> return [(x, r)] + (l, TUVar x) -> return [(x, l)] + -- Case for Free Foil variables (not supported for now) + (FreeFoil.Var x, FreeFoil.Var y) + | x == y -> return [] + -- Case of non-trivial arbitrary nodes + (FreeFoil.Node l, FreeFoil.Node r) -> + -- zipMatch (TArrowSig x1 x2) (TArrowSig y1 y2) + -- = Just (TArrowSig (x1, y1) (x2, y2)) + case FreeFoil.zipMatch l r of + Nothing -> Left ("cannot unify " ++ show c) + -- `zipMatch` takes out corresponding terms from a node that we need + -- to unify further. + Just lr -> unify (F.toList lr) -- ignores "scopes", only works with "terms" + (lhs, rhs) -> Left ("cannot unify " ++ show lhs ++ show rhs) + +infixr 6 +++ + +(+++) :: [USubst'] -> [USubst'] -> [USubst'] +xs +++ ys = map (applySubstsInSubsts ys) xs ++ ys + +unify :: [Constraint] -> Either String [USubst'] +unify [] = return [] +unify (c : cs) = do + substs <- unify1 c + substs' <- unify (map (applySubstsToConstraint substs) cs) + return (substs +++ substs') + +unifyWith :: [USubst'] -> [Constraint] -> Either String [USubst'] +unifyWith substs constraints = unify (map (applySubstsToConstraint substs) constraints) + +newtype TypeCheck n a = TypeCheck {runTypeCheck :: TypingContext n -> Either String (a, TypingContext n)} + deriving (Functor) + +-- instance Functor (TypeCheck n) where +-- fmap f (TypeCheck g) = TypeCheck $ \tc -> +-- case g tc of +-- Left err -> Left err +-- Right (x, tc') -> Right (f x, tc') + +instance Applicative (TypeCheck n) where + pure x = TypeCheck $ \tc -> Right (x, tc) + (<*>) = ap + +instance Monad (TypeCheck n) where + -- return x = TypeCheck $ \tc -> Right (x, tc) + + -- (>>=) :: TypeCheck a -> (a -> TypeCheck b) -> TypeCheck b + -- g :: TypingContext n -> Either String (a, TypingContext n) + -- TypeCheck g >>= f = TypeCheck $ \tc -> + -- case g tc of + -- Left err -> Left err + -- Right (x, tc') -> runTypeCheck (f x) tc' + -- + -- do + -- x <- TypeCheck g + -- f x + TypeCheck g >>= f = TypeCheck $ \tc -> do + (x, tc') <- g tc + runTypeCheck (f x) tc' + +applySubstsToConstraint :: [USubst'] -> Constraint -> Constraint +applySubstsToConstraint substs (l, r) = (applySubstsToType substs l, applySubstsToType substs r) + +applySubstToType :: (Foil.Distinct n) => USubst n -> Type n -> Type n +applySubstToType (ident, typ) (TUVar x) + | ident == x = typ + | otherwise = TUVar x +applySubstToType _ (FreeFoil.Var x) = FreeFoil.Var x +applySubstToType subst (FreeFoil.Node node) = + FreeFoil.Node (bimap (applySubstToScopedType subst) (applySubstToType subst) node) + where + applySubstToScopedType :: (Foil.Distinct n) => USubst n -> FreeFoil.ScopedAST FoilTypePattern TypeSig n -> FreeFoil.ScopedAST FoilTypePattern TypeSig n + applySubstToScopedType subst' (FreeFoil.ScopedAST binder body) = + case (Foil.assertExt binder, Foil.assertDistinct binder) of + (Foil.Ext, Foil.Distinct) -> + FreeFoil.ScopedAST binder (applySubstToType (fmap Foil.sink subst') body) + +applySubstsToType :: [USubst'] -> Type' -> Type' +applySubstsToType [] typ = typ +applySubstsToType (subst : rest) typ = applySubstsToType rest (applySubstToType subst typ) + +applySubstsInSubsts :: [USubst'] -> USubst' -> USubst' +applySubstsInSubsts substs (l, r) = (l, (applySubstsToType substs r)) + +deriving instance Functor (Foil.NameMap n) + +deriving instance Foldable (Foil.NameMap n) + +data TypingContext n = TypingContext + { tcConstraints :: [Constraint], + tcSubsts :: [USubst'], + tcTypings :: FreeFoil.NameMap n Type', + tcFreshId :: Int + } + +get :: TypeCheck n (TypingContext n) +get = TypeCheck $ \tc -> Right (tc, tc) + +put :: TypingContext n -> TypeCheck n () +put new = TypeCheck $ \_old -> Right ((), new) + +eitherToTypeCheck :: Either String a -> TypeCheck n a +eitherToTypeCheck (Left err) = TypeCheck $ \_tc -> Left err +eitherToTypeCheck (Right x) = TypeCheck $ \tc -> Right (x, tc) + +unifyTypeCheck :: TypeCheck n () +unifyTypeCheck = do + TypingContext constraints substs ctx freshId <- get + substs' <- eitherToTypeCheck (unifyWith substs constraints) + put (TypingContext [] (substs +++ substs') ctx freshId) + +enterScope :: Foil.NameBinder n l -> Type' -> TypeCheck l a -> TypeCheck n a +enterScope binder type_ code = do + TypingContext constraints substs ctx freshId <- get + let ctx' = Foil.addNameBinder binder type_ ctx + (x, TypingContext constraints'' substs'' ctx'' freshId'') <- + eitherToTypeCheck $ + runTypeCheck code (TypingContext constraints substs ctx' freshId) + let ctx''' = popNameBinder binder ctx'' + put (TypingContext constraints'' substs'' ctx''' freshId'') + return x + +addConstraints :: [Constraint] -> TypeCheck n () +addConstraints constrs = do + TypingContext constraints substs ctx freshId <- get + put (TypingContext (constrs ++ constraints) substs ctx freshId) + +freshTypeVar :: TypeCheck n Type' +freshTypeVar = do + TypingContext constraints substs ctx freshId <- get + put (TypingContext constraints substs ctx (freshId + 1)) + return (TUVar (makeIdent freshId)) + +-- | Recursively "reconstructs" type of an expression. +-- On success, returns the "reconstructed" type and collected constraints. +reconstructType :: Exp n -> TypeCheck n Type' +reconstructType ETrue = return TBool +reconstructType EFalse = return TBool +reconstructType (ENat _) = return TNat -- TypeCheck $ \tc -> Right (TNat, tc) +reconstructType (FreeFoil.Var x) = do + TypingContext constrs subst ctx freshId <- get + let xTyp = Foil.lookupName x ctx + let (specTyp, freshId2) = specialize xTyp freshId + put (TypingContext constrs subst ctx freshId2) + return specTyp +reconstructType (ELet eWhat (FoilPatternVar x) eExpr) = do + whatTyp <- reconstructType eWhat + unifyTypeCheck + (TypingContext _ substs ctx _) <- get + let whatTyp1 = applySubstsToType substs whatTyp + let ctx' = fmap (applySubstsToType substs) ctx + let ctxVars = foldl (\idents typ -> idents ++ allUVarsOfType typ) [] ctx' + let whatFreeIdents = filter (\i -> not (elem i ctxVars)) (allUVarsOfType whatTyp1) + let whatTyp2 = generalize whatFreeIdents whatTyp1 + enterScope x whatTyp2 (reconstructType eExpr) +reconstructType (EAdd lhs rhs) = do + lhsTyp <- reconstructType lhs + rhsTyp <- reconstructType rhs + addConstraints [(lhsTyp, TNat), (rhsTyp, TNat)] + return TNat +reconstructType (ESub lhs rhs) = do + lhsTyp <- reconstructType lhs + rhsTyp <- reconstructType rhs + addConstraints [(lhsTyp, TNat), (rhsTyp, TNat)] + return TNat +reconstructType (EIf eCond eThen eElse) = do + condTyp <- reconstructType eCond + thenTyp <- reconstructType eThen + elseTyp <- reconstructType eElse + addConstraints [(condTyp, TBool), (thenTyp, elseTyp)] + return thenTyp +reconstructType (EIsZero e) = do + eTyp <- reconstructType e + addConstraints [(eTyp, TNat)] + return TBool +reconstructType (EAbs (FoilPatternVar x) eBody) = do + paramType <- freshTypeVar + bodyTyp <- + enterScope x paramType $ + reconstructType eBody + return (TArrow paramType bodyTyp) +reconstructType (EApp eAbs eArg) = do + absTyp <- reconstructType eAbs + argTyp <- reconstructType eArg + resultTyp <- freshTypeVar + addConstraints [(absTyp, TArrow argTyp resultTyp)] + return resultTyp +reconstructType (ETyped e typ_) = do + let typ = toTypeClosed typ_ + eTyp <- reconstructType e + addConstraints [(eTyp, typ)] + return typ +reconstructType (EFor eFrom eTo (FoilPatternVar x) eBody) = do + fromTyp <- reconstructType eFrom + toTyp <- reconstructType eTo + addConstraints [(fromTyp, TNat), (toTyp, TNat)] + enterScope x TNat $ + reconstructType eBody + +allUVarsOfType :: Type' -> [Raw.UVarIdent] +allUVarsOfType (TUVar ident) = [ident] +allUVarsOfType (FreeFoil.Var _) = [] +allUVarsOfType (FreeFoil.Node node) = foldl (\idents typ -> idents ++ allUVarsOfType typ) [] node + +popNameBinder :: Foil.NameBinder n l -> Foil.NameMap l a -> Foil.NameMap n a +popNameBinder name (Foil.NameMap m) = Foil.NameMap (IntMap.delete (Foil.nameId (Foil.nameOf name)) m) + +unificationVarIdentsBetween :: Int -> Int -> [Raw.UVarIdent] +unificationVarIdentsBetween a b = map makeIdent [a .. (b - 1)] + +makeIdent :: Int -> Raw.UVarIdent +makeIdent i = Raw.UVarIdent ("?u" ++ (show i)) + +-- >>> generalize ["?a", "?b"] "?a -> ?b -> ?a" +-- forall x0 . forall x1 . x0 -> x1 -> x0 +-- >>> generalize ["?b", "?a"] "?a -> ?b -> ?a" +-- forall x0 . forall x1 . x1 -> x0 -> x1 +generalize :: [Raw.UVarIdent] -> Type' -> Type' +generalize = go Foil.emptyScope + where + go :: (Foil.Distinct n) => Foil.Scope n -> [Raw.UVarIdent] -> Type n -> Type n + go _ [] type_ = type_ + go ctx (x : xs) type_ = Foil.withFresh ctx $ \binder -> + let newScope = Foil.extendScope binder ctx + x' = FreeFoil.Var (Foil.nameOf binder) + type' = applySubstToType (x, x') (Foil.sink type_) + in TForAll (FoilTPatternVar binder) (go newScope xs type') + +-- addSubst +-- :: forall e i o i'. Substitution e i o +-- -> NameBinder i i' +-- -> e o +-- -> Substitution e i' o + +-- binder :: NameBinder VoidS l0 + +-- addSubst identitySubst :: NameBinder io i' -> e io -> Substitution e i' io +-- addSubst identitySubst binder :: e VoidS -> Substitution e l0 VoidS +-- addSubst identitySubst binder ... :: Substitution e l0 VoidS + +-- >>> specialize "forall a. forall b. a -> b" 6 +-- (?u6 -> ?u7,8) +specialize :: Type' -> Int -> (Type', Int) +specialize (TForAll (FoilTPatternVar binder) type_) freshId = + let subst = Foil.addSubst Foil.identitySubst binder (TUVar (makeIdent freshId)) + in specialize (FreeFoil.substitute Foil.emptyScope subst type_) (freshId + 1) +specialize type_ freshId = (type_, freshId) diff --git a/src/FreeFoilTypecheck/SystemF/Eval.hs b/src/FreeFoilTypecheck/SystemF/Eval.hs new file mode 100644 index 0000000..0ce271f --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Eval.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE LambdaCase #-} + +module FreeFoilTypecheck.SystemF.Eval where + +import Control.Monad (forM) +import Control.Monad.Foil (Distinct, addSubst, identitySubst) +-- import qualified Control.Monad.Foil as Foil +import Control.Monad.Free.Foil (AST (Var), substitute) +import FreeFoilTypecheck.SystemF.Syntax +import FreeFoilTypecheck.SystemF.Typecheck (Context, nameMapToScope) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Control.Monad.Foil (emptyNameMap) + +-- | +-- >>> eval emptyNameMap "if (iszero (2 - (1 + 1))) then true else 0" +-- Right true +-- >>> eval emptyNameMap "if (iszero (2 - (true + 1))) then true else 0" +-- Left "Unsupported expression in addition" +-- >>> eval emptyNameMap "ΛX. λx:X. x" +-- Right Λ x0 . λ x1 : x0 . x1 +eval :: (Distinct n) => Context n -> Term n -> Either String (Term n) +eval _scope (Var x) = Right (Var x) +eval _scope ETrue = Right ETrue +eval _scope EFalse = Right EFalse +eval _scope (ENat n) = Right (ENat n) +eval scope (EAdd l r) = do + l' <- eval scope l + r' <- eval scope r + case (l', r') of + (ENat x, ENat y) -> Right (ENat (x + y)) + _ -> Left "Unsupported expression in addition" +eval scope (ESub l r) = do + l' <- eval scope l + r' <- eval scope r + case (l', r') of + (ENat x, ENat y) -> Right (ENat (x - y)) + _ -> Left "Unsupported expression in subtraction" +eval scope (EIf cond then_ else_) = do + cond' <- eval scope cond + case cond' of + ETrue -> eval scope then_ + EFalse -> eval scope else_ + _ -> Left "Unsupported condition in if statement" +eval scope (EIsZero n) = + eval scope n >>= \case + ENat n' + | n' == 0 -> Right ETrue + | otherwise -> Right EFalse + _ -> Left "Unsupported expression in iszero" +eval scope (ETyped e _) = eval scope e +eval scope (ELet e1 (FoilPatternVar xp) e2) = do + e1' <- eval scope e1 + let subst = addSubst identitySubst xp e1' + eval scope (substitute (nameMapToScope scope) subst e2) +eval _scope (EAbsTyped type_ x e) = Right (EAbsTyped type_ x e) +eval _scope (EAbsUntyped x e) = Right (EAbsUntyped x e) +eval scope (EApp e1 e2) = do + e1' <- eval scope e1 + e2' <- eval scope e2 + case e1' of + EAbsTyped _ (FoilPatternVar xp) e -> do + let subst = addSubst identitySubst xp e2' + eval scope (substitute (nameMapToScope scope) subst e) + _ -> Left "Unsupported expression in application" +eval scope (EFor e1 e2 (FoilPatternVar xp) expr) = do + e1_val <- eval scope e1 + e2_val <- eval scope e2 + case (e1_val, e2_val) of + (ENat from, ENat to) -> do + let ys = [from .. to] + results <- forM ys $ \y -> do + let subst = addSubst identitySubst xp (ENat y) + eval scope (substitute (nameMapToScope scope) subst expr) + return (last results) + _ -> Left "Invalid expression in the range of for-loop" +eval scope (ETApp e t) = do + e' <- eval scope e + t' <- eval scope t + case e' of + ETAbs (FoilPatternVar xp) body -> do + let subst = addSubst identitySubst xp t' + eval scope (substitute (nameMapToScope scope) subst body) + _other -> Left ("Unexpected type application to " <> show _other) +eval _scope (ETAbs pat e) = Right (ETAbs pat e) + +eval _ TNat = Right TNat +eval _ TType = Right TType +eval _ TBool = Right TBool +eval _ (TArrow l r) = Right (TArrow l r) +eval _ (TForAll p b) = Right (TForAll p b) +eval _ (TUVar n) = Right (TUVar n) diff --git a/src/HM/Interpret.hs b/src/FreeFoilTypecheck/SystemF/Interpret.hs similarity index 63% rename from src/HM/Interpret.hs rename to src/FreeFoilTypecheck/SystemF/Interpret.hs index 853efe1..5822e92 100644 --- a/src/HM/Interpret.hs +++ b/src/FreeFoilTypecheck/SystemF/Interpret.hs @@ -1,10 +1,10 @@ -module HM.Interpret where +module FreeFoilTypecheck.SystemF.Interpret where -import Control.Monad.Foil (emptyNameMap, emptyScope) -import HM.Eval -import HM.Parser.Par -import HM.Syntax (toExpClosed) -import HM.Typecheck +import Control.Monad.Foil (emptyNameMap) +import FreeFoilTypecheck.SystemF.Eval +import FreeFoilTypecheck.SystemF.Parser.Par +import FreeFoilTypecheck.SystemF.Syntax (toTermClosed) +import FreeFoilTypecheck.SystemF.Typecheck data Result = Success String -- Output of evaluation. @@ -19,11 +19,11 @@ data ErrorKind interpret :: String -> Result interpret input = - case toExpClosed <$> pExp tokens of + case toTermClosed <$> pTerm tokens of Left err -> Failure ParsingError ("Parsing error: " ++ err) Right e -> case inferType emptyNameMap e of Left err -> Failure TypecheckingError ("Typechecking error: " ++ err) - Right _type -> case eval emptyScope e of + Right _type -> case eval emptyNameMap e of Left err -> Failure EvaluationError ("Evaluation error: " ++ err) Right outExp -> Success (show outExp) where diff --git a/src/FreeFoilTypecheck/SystemF/Parser/Abs.hs b/src/FreeFoilTypecheck/SystemF/Parser/Abs.hs new file mode 100644 index 0000000..8d9a714 --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Parser/Abs.hs @@ -0,0 +1,54 @@ +-- File generated by the BNF Converter (bnfc 2.9.5). + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | The abstract syntax of language Parser. + +module FreeFoilTypecheck.SystemF.Parser.Abs where + +import Prelude (Integer, String) +import qualified Prelude as C (Eq, Ord, Show, Read) +import qualified Data.String + +import qualified Data.Data as C (Data, Typeable) +import qualified GHC.Generics as C (Generic) + +data Pattern = PatternVar Ident + deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) + +data Term + = EVar Ident + | ETrue + | EFalse + | ENat Integer + | EAdd Term Term + | ESub Term Term + | EIf Term Term Term + | EIsZero Term + | ETyped Term Term + | ELet Pattern Term ScopedTerm + | EAbsTyped Pattern Term ScopedTerm + | EAbsUntyped Pattern ScopedTerm + | EApp Term Term + | ETAbs Pattern ScopedTerm + | ETApp Term Term + | EFor Pattern Term Term ScopedTerm + | TUVar UVarIdent + | TNat + | TBool + | TType + | TArrow Term Term + | TForAll Pattern ScopedTerm + deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) + +data ScopedTerm = ScopedTerm Term + deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) + +newtype Ident = Ident String + deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic, Data.String.IsString) + +newtype UVarIdent = UVarIdent String + deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic, Data.String.IsString) + diff --git a/src/FreeFoilTypecheck/SystemF/Parser/Doc.txt b/src/FreeFoilTypecheck/SystemF/Parser/Doc.txt new file mode 100644 index 0000000..6e26205 --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Parser/Doc.txt @@ -0,0 +1,82 @@ +The Language Parser +BNF Converter + + +%Process by txt2tags to generate html or latex + + + +This document was automatically generated by the //BNF-Converter//. It was generated together with the lexer, the parser, and the abstract syntax module, which guarantees that the document matches with the implementation of the language (provided no hand-hacking has taken place). + +==The lexical structure of Parser== +===Identifiers=== +Identifiers //Ident// are unquoted strings beginning with a letter, +followed by any combination of letters, digits, and the characters ``_ '`` +reserved words excluded. + + +===Literals=== +Integer literals //Integer// are nonempty sequences of digits. + + + + +UVarIdent literals are recognized by the regular expression +`````'?' letter ('_' | digit | letter)*````` + + +===Reserved words and symbols=== +The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions. + +The reserved words used in Parser are the following: + | ``Bool`` | ``Nat`` | ``Type`` | ``do`` + | ``else`` | ``false`` | ``for`` | ``forall`` + | ``if`` | ``in`` | ``iszero`` | ``let`` + | ``then`` | ``true`` | ``Λ`` | ``λ`` + +The symbols used in Parser are the following: + | + | - | ( | ) + | : | = | . | [ + | ] | .. | -> | + +===Comments=== +There are no single-line comments in the grammar.There are no multiple-line comments in the grammar. + +==The syntactic structure of Parser== +Non-terminals are enclosed between < and >. +The symbols -> (production), **|** (union) +and **eps** (empty rule) belong to the BNF notation. +All other symbols are terminals. + + | //Pattern// | -> | //Ident// + | //Term3// | -> | //Ident// + | | **|** | ``true`` + | | **|** | ``false`` + | | **|** | //Integer// + | | **|** | //UVarIdent// + | | **|** | ``Nat`` + | | **|** | ``Bool`` + | | **|** | ``Type`` + | | **|** | ``(`` //Term// ``)`` + | //Term2// | -> | //Term2// ``+`` //Term3// + | | **|** | //Term2// ``-`` //Term3// + | | **|** | ``iszero`` ``(`` //Term// ``)`` + | | **|** | //Term3// ``->`` //Term2// + | | **|** | //Term3// + | //Term1// | -> | ``if`` //Term1// ``then`` //Term1// ``else`` //Term1// + | | **|** | ``let`` //Pattern// ``=`` //Term1// ``in`` //ScopedTerm// + | | **|** | ``λ`` //Pattern// ``:`` //Term// ``.`` //ScopedTerm// + | | **|** | ``λ`` //Pattern// ``.`` //ScopedTerm// + | | **|** | //Term1// //Term2// + | | **|** | ``Λ`` //Pattern// ``.`` //ScopedTerm// + | | **|** | //Term1// ``[`` //Term// ``]`` + | | **|** | ``for`` //Pattern// ``in`` ``[`` //Term1// ``..`` //Term1// ``]`` ``do`` //ScopedTerm// + | | **|** | ``forall`` //Pattern// ``.`` //ScopedTerm// + | | **|** | //Term2// + | //Term// | -> | //Term1// ``:`` //Term// + | | **|** | //Term1// + | //ScopedTerm// | -> | //Term1// + + + +%% File generated by the BNF Converter (bnfc 2.9.5). diff --git a/src/HM/Parser/ErrM.hs b/src/FreeFoilTypecheck/SystemF/Parser/ErrM.hs similarity index 95% rename from src/HM/Parser/ErrM.hs rename to src/FreeFoilTypecheck/SystemF/Parser/ErrM.hs index 203c500..7fd8606 100644 --- a/src/HM/Parser/ErrM.hs +++ b/src/FreeFoilTypecheck/SystemF/Parser/ErrM.hs @@ -17,7 +17,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE FlexibleInstances #-} -module HM.Parser.ErrM where +module FreeFoilTypecheck.SystemF.Parser.ErrM where import Prelude (id, const, Either(..), String) @@ -56,7 +56,7 @@ instance MonadPlus Err where -- Copyright (C) 2004 Author: Aarne Ranta -- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE. -module HM.Parser.ErrM where +module FreeFoilTypecheck.SystemF.Parser.ErrM where -- the Error monad: like Maybe type with error msgs diff --git a/src/FreeFoilTypecheck/SystemF/Parser/Lex.hs b/src/FreeFoilTypecheck/SystemF/Parser/Lex.hs new file mode 100644 index 0000000..b4f9d8d --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Parser/Lex.hs @@ -0,0 +1,1779 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE CPP #-} +{-# LINE 4 "Lex.x" #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -w #-} + +{-# LANGUAGE PatternSynonyms #-} + +module FreeFoilTypecheck.SystemF.Parser.Lex where + +import Prelude + +import qualified Data.Bits +import Data.Char (ord) +import Data.Function (on) +import Data.Word (Word8) +#include "ghcconfig.h" +import qualified Data.Array +alex_tab_size :: Int +alex_tab_size = 8 +alex_base :: Data.Array.Array Int Int +alex_base = Data.Array.listArray (0 :: Int, 11) + [ -8 + , 140 + , -40 + , -148 + , 0 + , -1 + , -13 + , -49 + , -34 + , 239 + , 234 + , 370 + ] + +alex_table :: Data.Array.Array Int Int +alex_table = Data.Array.listArray (0 :: Int, 625) + [ 0 + , 5 + , 5 + , 5 + , 5 + , 5 + , 4 + , 4 + , 5 + , 5 + , 5 + , 5 + , 5 + , 4 + , 8 + , 8 + , 8 + , 8 + , 8 + , 8 + , 8 + , 8 + , 8 + , 8 + , 5 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 5 + , 4 + , 4 + , 0 + , 4 + , 0 + , 7 + , 2 + , 4 + , 8 + , 8 + , 8 + , 8 + , 8 + , 8 + , 8 + , 8 + , 8 + , 8 + , 4 + , 0 + , 0 + , 4 + , 0 + , 11 + , 0 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 4 + , 0 + , 4 + , 0 + , 0 + , 0 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 10 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 3 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 0 + , 0 + , 0 + , 1 + , 0 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 9 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 0 + , 0 + , 0 + , 0 + , 9 + , 6 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 0 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 0 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 9 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 10 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 6 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + ] + +alex_check :: Data.Array.Array Int Int +alex_check = Data.Array.listArray (0 :: Int, 625) + [ -1 + , 9 + , 10 + , 11 + , 12 + , 13 + , 46 + , 155 + , 9 + , 10 + , 11 + , 12 + , 13 + , 62 + , 48 + , 49 + , 50 + , 51 + , 52 + , 53 + , 54 + , 55 + , 56 + , 57 + , 32 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , 32 + , 40 + , 41 + , -1 + , 43 + , -1 + , 45 + , 46 + , 187 + , 48 + , 49 + , 50 + , 51 + , 52 + , 53 + , 54 + , 55 + , 56 + , 57 + , 58 + , -1 + , -1 + , 61 + , -1 + , 63 + , -1 + , 65 + , 66 + , 67 + , 68 + , 69 + , 70 + , 71 + , 72 + , 73 + , 74 + , 75 + , 76 + , 77 + , 78 + , 79 + , 80 + , 81 + , 82 + , 83 + , 84 + , 85 + , 86 + , 87 + , 88 + , 89 + , 90 + , 91 + , -1 + , 93 + , -1 + , -1 + , -1 + , 97 + , 98 + , 99 + , 100 + , 101 + , 102 + , 103 + , 104 + , 105 + , 106 + , 107 + , 108 + , 109 + , 110 + , 111 + , 112 + , 113 + , 114 + , 115 + , 116 + , 117 + , 118 + , 119 + , 120 + , 121 + , 122 + , 128 + , 129 + , 130 + , 131 + , 132 + , 133 + , 134 + , 135 + , 136 + , 137 + , 138 + , 139 + , 140 + , 141 + , 142 + , 143 + , 144 + , 145 + , 146 + , 147 + , 148 + , 149 + , 150 + , -1 + , 152 + , 153 + , 154 + , 155 + , 156 + , 157 + , 158 + , 159 + , 160 + , 161 + , 162 + , 163 + , 164 + , 165 + , 166 + , 167 + , 168 + , 169 + , 170 + , 171 + , 172 + , 173 + , 174 + , 175 + , 176 + , 177 + , 178 + , 179 + , 180 + , 181 + , 182 + , -1 + , 184 + , 185 + , 186 + , 187 + , 188 + , 189 + , 190 + , 191 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , 195 + , 48 + , 49 + , 50 + , 51 + , 52 + , 53 + , 54 + , 55 + , 56 + , 57 + , 206 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , 65 + , 66 + , 67 + , 68 + , 69 + , 70 + , 71 + , 72 + , 73 + , 74 + , 75 + , 76 + , 77 + , 78 + , 79 + , 80 + , 81 + , 82 + , 83 + , 84 + , 85 + , 86 + , 87 + , 88 + , 89 + , 90 + , -1 + , -1 + , -1 + , -1 + , 95 + , -1 + , 97 + , 98 + , 99 + , 100 + , 101 + , 102 + , 103 + , 104 + , 105 + , 106 + , 107 + , 108 + , 109 + , 110 + , 111 + , 112 + , 113 + , 114 + , 115 + , 116 + , 117 + , 118 + , 119 + , 120 + , 121 + , 122 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , 39 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , 48 + , 49 + , 50 + , 51 + , 52 + , 53 + , 54 + , 55 + , 56 + , 57 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , 65 + , 66 + , 67 + , 68 + , 69 + , 70 + , 71 + , 72 + , 73 + , 74 + , 75 + , 76 + , 77 + , 78 + , 79 + , 80 + , 81 + , 82 + , 83 + , 84 + , 85 + , 86 + , 87 + , 88 + , 89 + , 90 + , -1 + , -1 + , -1 + , -1 + , 95 + , 195 + , 97 + , 98 + , 99 + , 100 + , 101 + , 102 + , 103 + , 104 + , 105 + , 106 + , 107 + , 108 + , 109 + , 110 + , 111 + , 112 + , 113 + , 114 + , 115 + , 116 + , 117 + , 118 + , 119 + , 120 + , 121 + , 122 + , 128 + , 129 + , 130 + , 131 + , 132 + , 133 + , 134 + , 135 + , 136 + , 137 + , 138 + , 139 + , 140 + , 141 + , 142 + , 143 + , 144 + , 145 + , 146 + , 147 + , 148 + , 149 + , 150 + , -1 + , 152 + , 153 + , 154 + , 155 + , 156 + , 157 + , 158 + , 159 + , 160 + , 161 + , 162 + , 163 + , 164 + , 165 + , 166 + , 167 + , 168 + , 169 + , 170 + , 171 + , 172 + , 173 + , 174 + , 175 + , 176 + , 177 + , 178 + , 179 + , 180 + , 181 + , 182 + , -1 + , 184 + , 185 + , 186 + , 187 + , 188 + , 189 + , 190 + , 191 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , 195 + , 65 + , 66 + , 67 + , 68 + , 69 + , 70 + , 71 + , 72 + , 73 + , 74 + , 75 + , 76 + , 77 + , 78 + , 79 + , 80 + , 81 + , 82 + , 83 + , 84 + , 85 + , 86 + , 87 + , 88 + , 89 + , 90 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , 97 + , 98 + , 99 + , 100 + , 101 + , 102 + , 103 + , 104 + , 105 + , 106 + , 107 + , 108 + , 109 + , 110 + , 111 + , 112 + , 113 + , 114 + , 115 + , 116 + , 117 + , 118 + , 119 + , 120 + , 121 + , 122 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , 195 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + ] + +alex_deflt :: Data.Array.Array Int Int +alex_deflt = Data.Array.listArray (0 :: Int, 11) + [ -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + ] + +alex_accept = Data.Array.listArray (0 :: Int, 11) + [ AlexAccNone + , AlexAcc 5 + , AlexAcc 4 + , AlexAccNone + , AlexAcc 3 + , AlexAccSkip + , AlexAccNone + , AlexAcc 2 + , AlexAcc 1 + , AlexAcc 0 + , AlexAccNone + , AlexAccNone + ] + +alex_actions = Data.Array.array (0 :: Int, 6) + [ (5,alex_action_2) + , (4,alex_action_1) + , (3,alex_action_1) + , (2,alex_action_1) + , (1,alex_action_4) + , (0,alex_action_3) + ] + +alex_action_1 = tok (eitherResIdent TV) +alex_action_2 = tok (eitherResIdent T_UVarIdent) +alex_action_3 = tok (eitherResIdent TV) +alex_action_4 = tok TI + +#define ALEX_NOPRED 1 +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +#ifdef ALEX_GHC +# define ILIT(n) n# +# define IBOX(n) (I# (n)) +# define FAST_INT Int# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +# if __GLASGOW_HASKELL__ > 706 +# define GTE(n,m) (GHC.Exts.tagToEnum# (n >=# m)) +# define EQ(n,m) (GHC.Exts.tagToEnum# (n ==# m)) +# else +# define GTE(n,m) (n >=# m) +# define EQ(n,m) (n ==# m) +# endif +# define PLUS(n,m) (n +# m) +# define MINUS(n,m) (n -# m) +# define TIMES(n,m) (n *# m) +# define NEGATE(n) (negateInt# (n)) +# define IF_GHC(x) (x) +#else +# define ILIT(n) (n) +# define IBOX(n) (n) +# define FAST_INT Int +# define GTE(n,m) (n >= m) +# define EQ(n,m) (n == m) +# define PLUS(n,m) (n + m) +# define MINUS(n,m) (n - m) +# define TIMES(n,m) (n * m) +# define NEGATE(n) (negate (n)) +# define IF_GHC(x) +#endif + +#ifdef ALEX_GHC +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else +#if __GLASGOW_HASKELL__ >= 901 + GHC.Exts.int16ToInt# +#endif + (indexInt16OffAddr# arr off) +#endif +#else +alexIndexInt16OffAddr = (Data.Array.!) +#endif + +#ifdef ALEX_GHC +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else +#if __GLASGOW_HASKELL__ >= 901 + GHC.Exts.int32ToInt# +#endif + (indexInt32OffAddr# arr off) +#endif +#else +alexIndexInt32OffAddr = (Data.Array.!) +#endif + +#ifdef ALEX_GHC +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#else +quickIndex = (Data.Array.!) +#endif + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ IBOX(sc) + = alexScanUser undefined input__ IBOX(sc) + +alexScanUser user__ input__ IBOX(sc) + = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> +#ifdef ALEX_DEBUG + Debug.Trace.trace ("End of input.") $ +#endif + AlexEOF + Just _ -> +#ifdef ALEX_DEBUG + Debug.Trace.trace ("Error.") $ +#endif + AlexError input__' + + (AlexLastSkip input__'' len, _) -> +#ifdef ALEX_DEBUG + Debug.Trace.trace ("Skipping.") $ +#endif + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> +#ifdef ALEX_DEBUG + Debug.Trace.trace ("Accept.") $ +#endif + AlexToken input__''' len ((Data.Array.!) alex_actions k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` IBOX(s))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> +#ifdef ALEX_DEBUG + Debug.Trace.trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c ++ " " ++ (show . chr . fromIntegral) c) $ +#endif + case fromIntegral c of { IBOX(ord_c) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = PLUS(base,ord_c) + + new_s = if GTE(offset,ILIT(0)) + && let check = alexIndexInt16OffAddr alex_check offset + in EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + ILIT(-1) -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input +#ifdef ALEX_LATIN1 + PLUS(len,ILIT(1)) + -- issue 119: in the latin1 encoding, *each* byte is one character +#else + (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) +#endif + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ IBOX(len) + check_accs (AlexAccSkip) = AlexLastSkip input__ IBOX(len) +#ifndef ALEX_NOPRED + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastAcc a input__ IBOX(len) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastSkip input__ IBOX(len) + | otherwise + = check_accs rest +#endif + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip +#ifndef ALEX_NOPRED + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr Data.Array.! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext IBOX(sc) user__ _ _ input__ = + case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. +#endif +{-# LINE 54 "Lex.x" #-} +-- | Create a token with position. +tok :: (String -> Tok) -> (Posn -> String -> Token) +tok f p = PT p . f + +-- | Token without position. +data Tok + = TK {-# UNPACK #-} !TokSymbol -- ^ Reserved word or symbol. + | TL !String -- ^ String literal. + | TI !String -- ^ Integer literal. + | TV !String -- ^ Identifier. + | TD !String -- ^ Float literal. + | TC !String -- ^ Character literal. + | T_UVarIdent !String + deriving (Eq, Show, Ord) + +-- | Smart constructor for 'Tok' for the sake of backwards compatibility. +pattern TS :: String -> Int -> Tok +pattern TS t i = TK (TokSymbol t i) + +-- | Keyword or symbol tokens have a unique ID. +data TokSymbol = TokSymbol + { tsText :: String + -- ^ Keyword or symbol text. + , tsID :: !Int + -- ^ Unique ID. + } deriving (Show) + +-- | Keyword/symbol equality is determined by the unique ID. +instance Eq TokSymbol where (==) = (==) `on` tsID + +-- | Keyword/symbol ordering is determined by the unique ID. +instance Ord TokSymbol where compare = compare `on` tsID + +-- | Token with position. +data Token + = PT Posn Tok + | Err Posn + deriving (Eq, Show, Ord) + +-- | Pretty print a position. +printPosn :: Posn -> String +printPosn (Pn _ l c) = "line " ++ show l ++ ", column " ++ show c + +-- | Pretty print the position of the first token in the list. +tokenPos :: [Token] -> String +tokenPos (t:_) = printPosn (tokenPosn t) +tokenPos [] = "end of file" + +-- | Get the position of a token. +tokenPosn :: Token -> Posn +tokenPosn (PT p _) = p +tokenPosn (Err p) = p + +-- | Get line and column of a token. +tokenLineCol :: Token -> (Int, Int) +tokenLineCol = posLineCol . tokenPosn + +-- | Get line and column of a position. +posLineCol :: Posn -> (Int, Int) +posLineCol (Pn _ l c) = (l,c) + +-- | Convert a token into "position token" form. +mkPosToken :: Token -> ((Int, Int), String) +mkPosToken t = (tokenLineCol t, tokenText t) + +-- | Convert a token to its text. +tokenText :: Token -> String +tokenText t = case t of + PT _ (TS s _) -> s + PT _ (TL s) -> show s + PT _ (TI s) -> s + PT _ (TV s) -> s + PT _ (TD s) -> s + PT _ (TC s) -> s + Err _ -> "#error" + PT _ (T_UVarIdent s) -> s + +-- | Convert a token to a string. +prToken :: Token -> String +prToken t = tokenText t + +-- | Finite map from text to token organized as binary search tree. +data BTree + = N -- ^ Nil (leaf). + | B String Tok BTree BTree + -- ^ Binary node. + deriving (Show) + +-- | Convert potential keyword into token or use fallback conversion. +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = treeFind resWords + where + treeFind N = tv s + treeFind (B a t left right) = + case compare s a of + LT -> treeFind left + GT -> treeFind right + EQ -> t + +-- | The keywords and symbols of the language organized as binary search tree. +resWords :: BTree +resWords = + b "]" 14 + (b ".." 7 + (b "-" 4 + (b ")" 2 (b "(" 1 N N) (b "+" 3 N N)) (b "." 6 (b "->" 5 N N) N)) + (b "Nat" 11 + (b "=" 9 (b ":" 8 N N) (b "Bool" 10 N N)) + (b "[" 13 (b "Type" 12 N N) N))) + (b "in" 21 + (b "for" 18 + (b "else" 16 (b "do" 15 N N) (b "false" 17 N N)) + (b "if" 20 (b "forall" 19 N N) N)) + (b "true" 25 + (b "let" 23 (b "iszero" 22 N N) (b "then" 24 N N)) + (b "\955" 27 (b "\923" 26 N N) N))) + where + b s n = B bs (TS bs n) + where + bs = s + +-- | Unquote string literal. +unescapeInitTail :: String -> String +unescapeInitTail = id . unesc . tail . id + where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '\\':'r':cs -> '\r' : unesc cs + '\\':'f':cs -> '\f' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +------------------------------------------------------------------- +-- Alex wrapper code. +-- A modified "posn" wrapper. +------------------------------------------------------------------- + +data Posn = Pn !Int !Int !Int + deriving (Eq, Show, Ord) + +alexStartPos :: Posn +alexStartPos = Pn 0 1 1 + +alexMove :: Posn -> Char -> Posn +alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 +alexMove (Pn a l c) _ = Pn (a+1) l (c+1) + +type Byte = Word8 + +type AlexInput = (Posn, -- current position, + Char, -- previous char + [Byte], -- pending bytes on the current char + String) -- current input string + +tokens :: String -> [Token] +tokens str = go (alexStartPos, '\n', [], str) + where + go :: AlexInput -> [Token] + go inp@(pos, _, _, str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError (pos, _, _, _) -> [Err pos] + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : (go inp') + +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s)) +alexGetByte (p, _, [], s) = + case s of + [] -> Nothing + (c:s) -> + let p' = alexMove p c + (b:bs) = utf8Encode c + in p' `seq` Just (b, (p', c, bs, s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p, c, bs, s) = c + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +utf8Encode :: Char -> [Word8] +utf8Encode = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) + , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] diff --git a/src/FreeFoilTypecheck/SystemF/Parser/Lex.x b/src/FreeFoilTypecheck/SystemF/Parser/Lex.x new file mode 100644 index 0000000..2694d15 --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Parser/Lex.x @@ -0,0 +1,257 @@ +-- -*- haskell -*- File generated by the BNF Converter (bnfc 2.9.5). + +-- Lexer definition for use with Alex 3 +{ +{-# OPTIONS -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -w #-} + +{-# LANGUAGE PatternSynonyms #-} + +module FreeFoilTypecheck.SystemF.Parser.Lex where + +import Prelude + +import qualified Data.Bits +import Data.Char (ord) +import Data.Function (on) +import Data.Word (Word8) +} + +-- Predefined character classes + +$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter (215 = \times) FIXME +$s = [a-z\222-\255] # [\247] -- small isolatin1 letter (247 = \div ) FIXME +$l = [$c $s] -- letter +$d = [0-9] -- digit +$i = [$l $d _ '] -- identifier character +$u = [. \n] -- universal: any character + +-- Symbols and non-identifier-like reserved words + +@rsyms = \λ | \Λ | \+ | \- | \( | \) | \: | \= | \. | \[ | \] | \. \. | \- \> + +:- + +-- Whitespace (skipped) +$white+ ; + +-- Symbols +@rsyms + { tok (eitherResIdent TV) } + +-- token UVarIdent +\? $l (\_ | ($d | $l)) * + { tok (eitherResIdent T_UVarIdent) } + +-- Keywords and Ident +$l $i* + { tok (eitherResIdent TV) } + +-- Integer +$d+ + { tok TI } + +{ +-- | Create a token with position. +tok :: (String -> Tok) -> (Posn -> String -> Token) +tok f p = PT p . f + +-- | Token without position. +data Tok + = TK {-# UNPACK #-} !TokSymbol -- ^ Reserved word or symbol. + | TL !String -- ^ String literal. + | TI !String -- ^ Integer literal. + | TV !String -- ^ Identifier. + | TD !String -- ^ Float literal. + | TC !String -- ^ Character literal. + | T_UVarIdent !String + deriving (Eq, Show, Ord) + +-- | Smart constructor for 'Tok' for the sake of backwards compatibility. +pattern TS :: String -> Int -> Tok +pattern TS t i = TK (TokSymbol t i) + +-- | Keyword or symbol tokens have a unique ID. +data TokSymbol = TokSymbol + { tsText :: String + -- ^ Keyword or symbol text. + , tsID :: !Int + -- ^ Unique ID. + } deriving (Show) + +-- | Keyword/symbol equality is determined by the unique ID. +instance Eq TokSymbol where (==) = (==) `on` tsID + +-- | Keyword/symbol ordering is determined by the unique ID. +instance Ord TokSymbol where compare = compare `on` tsID + +-- | Token with position. +data Token + = PT Posn Tok + | Err Posn + deriving (Eq, Show, Ord) + +-- | Pretty print a position. +printPosn :: Posn -> String +printPosn (Pn _ l c) = "line " ++ show l ++ ", column " ++ show c + +-- | Pretty print the position of the first token in the list. +tokenPos :: [Token] -> String +tokenPos (t:_) = printPosn (tokenPosn t) +tokenPos [] = "end of file" + +-- | Get the position of a token. +tokenPosn :: Token -> Posn +tokenPosn (PT p _) = p +tokenPosn (Err p) = p + +-- | Get line and column of a token. +tokenLineCol :: Token -> (Int, Int) +tokenLineCol = posLineCol . tokenPosn + +-- | Get line and column of a position. +posLineCol :: Posn -> (Int, Int) +posLineCol (Pn _ l c) = (l,c) + +-- | Convert a token into "position token" form. +mkPosToken :: Token -> ((Int, Int), String) +mkPosToken t = (tokenLineCol t, tokenText t) + +-- | Convert a token to its text. +tokenText :: Token -> String +tokenText t = case t of + PT _ (TS s _) -> s + PT _ (TL s) -> show s + PT _ (TI s) -> s + PT _ (TV s) -> s + PT _ (TD s) -> s + PT _ (TC s) -> s + Err _ -> "#error" + PT _ (T_UVarIdent s) -> s + +-- | Convert a token to a string. +prToken :: Token -> String +prToken t = tokenText t + +-- | Finite map from text to token organized as binary search tree. +data BTree + = N -- ^ Nil (leaf). + | B String Tok BTree BTree + -- ^ Binary node. + deriving (Show) + +-- | Convert potential keyword into token or use fallback conversion. +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = treeFind resWords + where + treeFind N = tv s + treeFind (B a t left right) = + case compare s a of + LT -> treeFind left + GT -> treeFind right + EQ -> t + +-- | The keywords and symbols of the language organized as binary search tree. +resWords :: BTree +resWords = + b "]" 14 + (b ".." 7 + (b "-" 4 + (b ")" 2 (b "(" 1 N N) (b "+" 3 N N)) (b "." 6 (b "->" 5 N N) N)) + (b "Nat" 11 + (b "=" 9 (b ":" 8 N N) (b "Bool" 10 N N)) + (b "[" 13 (b "Type" 12 N N) N))) + (b "in" 21 + (b "for" 18 + (b "else" 16 (b "do" 15 N N) (b "false" 17 N N)) + (b "if" 20 (b "forall" 19 N N) N)) + (b "true" 25 + (b "let" 23 (b "iszero" 22 N N) (b "then" 24 N N)) + (b "\955" 27 (b "\923" 26 N N) N))) + where + b s n = B bs (TS bs n) + where + bs = s + +-- | Unquote string literal. +unescapeInitTail :: String -> String +unescapeInitTail = id . unesc . tail . id + where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '\\':'r':cs -> '\r' : unesc cs + '\\':'f':cs -> '\f' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +------------------------------------------------------------------- +-- Alex wrapper code. +-- A modified "posn" wrapper. +------------------------------------------------------------------- + +data Posn = Pn !Int !Int !Int + deriving (Eq, Show, Ord) + +alexStartPos :: Posn +alexStartPos = Pn 0 1 1 + +alexMove :: Posn -> Char -> Posn +alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 +alexMove (Pn a l c) _ = Pn (a+1) l (c+1) + +type Byte = Word8 + +type AlexInput = (Posn, -- current position, + Char, -- previous char + [Byte], -- pending bytes on the current char + String) -- current input string + +tokens :: String -> [Token] +tokens str = go (alexStartPos, '\n', [], str) + where + go :: AlexInput -> [Token] + go inp@(pos, _, _, str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError (pos, _, _, _) -> [Err pos] + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : (go inp') + +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s)) +alexGetByte (p, _, [], s) = + case s of + [] -> Nothing + (c:s) -> + let p' = alexMove p c + (b:bs) = utf8Encode c + in p' `seq` Just (b, (p', c, bs, s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p, c, bs, s) = c + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +utf8Encode :: Char -> [Word8] +utf8Encode = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) + , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] +} diff --git a/src/FreeFoilTypecheck/SystemF/Parser/Par.hs b/src/FreeFoilTypecheck/SystemF/Parser/Par.hs new file mode 100644 index 0000000..8fb66aa --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Parser/Par.hs @@ -0,0 +1,1780 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module FreeFoilTypecheck.SystemF.Parser.Par + ( happyError + , myLexer + , pPattern + , pTerm3 + , pTerm2 + , pTerm1 + , pTerm + , pScopedTerm + ) where + +import Prelude + +import qualified FreeFoilTypecheck.SystemF.Parser.Abs +import FreeFoilTypecheck.SystemF.Parser.Lex +import qualified Data.Array as Happy_Data_Array +import qualified Data.Bits as Bits +import Control.Applicative(Applicative(..)) +import Control.Monad (ap) + +-- parser produced by Happy Version 1.20.1.1 + +data HappyAbsSyn + = HappyTerminal (Token) + | HappyErrorToken Prelude.Int + | HappyAbsSyn9 (FreeFoilTypecheck.SystemF.Parser.Abs.Ident) + | HappyAbsSyn10 (Integer) + | HappyAbsSyn11 (FreeFoilTypecheck.SystemF.Parser.Abs.UVarIdent) + | HappyAbsSyn12 (FreeFoilTypecheck.SystemF.Parser.Abs.Pattern) + | HappyAbsSyn13 (FreeFoilTypecheck.SystemF.Parser.Abs.Term) + | HappyAbsSyn17 (FreeFoilTypecheck.SystemF.Parser.Abs.ScopedTerm) + +{- to allow type-synonyms as our monads (likely + - with explicitly-specified bind and return) + - in Haskell98, it seems that with + - /type M a = .../, then /(HappyReduction M)/ + - is not allowed. But Happy is a + - code-generator that can just substitute it. +type HappyReduction m = + Prelude.Int + -> (Token) + -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn) + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> m HappyAbsSyn +-} + +action_0, + action_1, + action_2, + action_3, + action_4, + action_5, + action_6, + action_7, + action_8, + action_9, + action_10, + action_11, + action_12, + action_13, + action_14, + action_15, + action_16, + action_17, + action_18, + action_19, + action_20, + action_21, + action_22, + action_23, + action_24, + action_25, + action_26, + action_27, + action_28, + action_29, + action_30, + action_31, + action_32, + action_33, + action_34, + action_35, + action_36, + action_37, + action_38, + action_39, + action_40, + action_41, + action_42, + action_43, + action_44, + action_45, + action_46, + action_47, + action_48, + action_49, + action_50, + action_51, + action_52, + action_53, + action_54, + action_55, + action_56, + action_57, + action_58, + action_59, + action_60, + action_61, + action_62, + action_63, + action_64, + action_65, + action_66, + action_67, + action_68, + action_69, + action_70, + action_71, + action_72, + action_73, + action_74, + action_75, + action_76, + action_77, + action_78, + action_79, + action_80, + action_81, + action_82, + action_83, + action_84, + action_85 :: () => Prelude.Int -> ({-HappyReduction (Err) = -} + Prelude.Int + -> (Token) + -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> (Err) HappyAbsSyn) + +happyReduce_6, + happyReduce_7, + happyReduce_8, + happyReduce_9, + happyReduce_10, + happyReduce_11, + happyReduce_12, + happyReduce_13, + happyReduce_14, + happyReduce_15, + happyReduce_16, + happyReduce_17, + happyReduce_18, + happyReduce_19, + happyReduce_20, + happyReduce_21, + happyReduce_22, + happyReduce_23, + happyReduce_24, + happyReduce_25, + happyReduce_26, + happyReduce_27, + happyReduce_28, + happyReduce_29, + happyReduce_30, + happyReduce_31, + happyReduce_32, + happyReduce_33, + happyReduce_34, + happyReduce_35, + happyReduce_36 :: () => ({-HappyReduction (Err) = -} + Prelude.Int + -> (Token) + -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> (Err) HappyAbsSyn) + +happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int +happyExpList = Happy_Data_Array.listArray (0,406) ([0,0,4096,0,7170,29186,0,7170,29250,0,7170,32478,0,7170,32478,0,7170,32478,0,0,4096,0,0,0,0,0,0,0,0,0,0,0,0,0,32,0,0,24,0,0,0,0,0,0,0,0,7170,32478,0,0,0,0,0,0,0,0,0,0,0,0,0,0,4096,0,0,4096,0,7170,32478,0,2,0,0,0,4096,0,0,0,0,0,4096,0,0,4096,0,0,0,0,0,0,0,15618,29250,0,0,0,0,15362,29250,0,24,0,0,0,0,0,0,0,0,0,0,0,7170,29186,0,7170,29186,0,24,0,0,7170,32478,0,7170,32478,0,320,0,0,64,0,0,512,0,0,7170,32478,0,15362,29506,0,64,0,0,0,32,0,4,0,0,7170,29250,0,0,0,0,0,0,0,8192,0,0,7170,32478,0,7170,32478,0,4,0,0,7170,32478,0,7170,32478,0,7170,32478,0,7170,32478,0,0,0,0,16384,0,0,0,0,0,0,0,0,0,0,0,64,0,0,0,0,0,0,0,0,15362,29282,0,0,0,0,15362,29251,0,0,0,0,7170,32478,0,15490,29250,0,7170,32478,0,7170,32478,0,7170,32478,0,0,0,0,0,0,0,0,0,0,7170,32478,0,31746,29250,0,32768,0,0,7170,32478,0,0,0,0 + ]) + +{-# NOINLINE happyExpListPerState #-} +happyExpListPerState st = + token_strs_expected + where token_strs = ["error","%dummy","%start_pPattern","%start_pTerm3","%start_pTerm2","%start_pTerm1","%start_pTerm","%start_pScopedTerm","Ident","Integer","UVarIdent","Pattern","Term3","Term2","Term1","Term","ScopedTerm","'('","')'","'+'","'-'","'->'","'.'","'..'","':'","'='","'Bool'","'Nat'","'Type'","'['","']'","'do'","'else'","'false'","'for'","'forall'","'if'","'in'","'iszero'","'let'","'then'","'true'","'\923'","'\955'","L_Ident","L_integ","L_UVarIdent","%eof"] + bit_start = st Prelude.* 48 + bit_end = (st Prelude.+ 1) Prelude.* 48 + read_bit = readArrayBit happyExpList + bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] + bits_indexed = Prelude.zip bits [0..47] + token_strs_expected = Prelude.concatMap f bits_indexed + f (Prelude.False, _) = [] + f (Prelude.True, nr) = [token_strs Prelude.!! nr] + +action_0 (45) = happyShift action_7 +action_0 (9) = happyGoto action_35 +action_0 (12) = happyGoto action_36 +action_0 _ = happyFail (happyExpListPerState 0) + +action_1 (18) = happyShift action_15 +action_1 (27) = happyShift action_16 +action_1 (28) = happyShift action_17 +action_1 (29) = happyShift action_18 +action_1 (34) = happyShift action_19 +action_1 (42) = happyShift action_25 +action_1 (45) = happyShift action_7 +action_1 (46) = happyShift action_28 +action_1 (47) = happyShift action_29 +action_1 (9) = happyGoto action_8 +action_1 (10) = happyGoto action_9 +action_1 (11) = happyGoto action_10 +action_1 (13) = happyGoto action_34 +action_1 _ = happyFail (happyExpListPerState 1) + +action_2 (18) = happyShift action_15 +action_2 (27) = happyShift action_16 +action_2 (28) = happyShift action_17 +action_2 (29) = happyShift action_18 +action_2 (34) = happyShift action_19 +action_2 (39) = happyShift action_23 +action_2 (42) = happyShift action_25 +action_2 (45) = happyShift action_7 +action_2 (46) = happyShift action_28 +action_2 (47) = happyShift action_29 +action_2 (9) = happyGoto action_8 +action_2 (10) = happyGoto action_9 +action_2 (11) = happyGoto action_10 +action_2 (13) = happyGoto action_11 +action_2 (14) = happyGoto action_33 +action_2 _ = happyFail (happyExpListPerState 2) + +action_3 (18) = happyShift action_15 +action_3 (27) = happyShift action_16 +action_3 (28) = happyShift action_17 +action_3 (29) = happyShift action_18 +action_3 (34) = happyShift action_19 +action_3 (35) = happyShift action_20 +action_3 (36) = happyShift action_21 +action_3 (37) = happyShift action_22 +action_3 (39) = happyShift action_23 +action_3 (40) = happyShift action_24 +action_3 (42) = happyShift action_25 +action_3 (43) = happyShift action_26 +action_3 (44) = happyShift action_27 +action_3 (45) = happyShift action_7 +action_3 (46) = happyShift action_28 +action_3 (47) = happyShift action_29 +action_3 (9) = happyGoto action_8 +action_3 (10) = happyGoto action_9 +action_3 (11) = happyGoto action_10 +action_3 (13) = happyGoto action_11 +action_3 (14) = happyGoto action_12 +action_3 (15) = happyGoto action_32 +action_3 _ = happyFail (happyExpListPerState 3) + +action_4 (18) = happyShift action_15 +action_4 (27) = happyShift action_16 +action_4 (28) = happyShift action_17 +action_4 (29) = happyShift action_18 +action_4 (34) = happyShift action_19 +action_4 (35) = happyShift action_20 +action_4 (36) = happyShift action_21 +action_4 (37) = happyShift action_22 +action_4 (39) = happyShift action_23 +action_4 (40) = happyShift action_24 +action_4 (42) = happyShift action_25 +action_4 (43) = happyShift action_26 +action_4 (44) = happyShift action_27 +action_4 (45) = happyShift action_7 +action_4 (46) = happyShift action_28 +action_4 (47) = happyShift action_29 +action_4 (9) = happyGoto action_8 +action_4 (10) = happyGoto action_9 +action_4 (11) = happyGoto action_10 +action_4 (13) = happyGoto action_11 +action_4 (14) = happyGoto action_12 +action_4 (15) = happyGoto action_30 +action_4 (16) = happyGoto action_31 +action_4 _ = happyFail (happyExpListPerState 4) + +action_5 (18) = happyShift action_15 +action_5 (27) = happyShift action_16 +action_5 (28) = happyShift action_17 +action_5 (29) = happyShift action_18 +action_5 (34) = happyShift action_19 +action_5 (35) = happyShift action_20 +action_5 (36) = happyShift action_21 +action_5 (37) = happyShift action_22 +action_5 (39) = happyShift action_23 +action_5 (40) = happyShift action_24 +action_5 (42) = happyShift action_25 +action_5 (43) = happyShift action_26 +action_5 (44) = happyShift action_27 +action_5 (45) = happyShift action_7 +action_5 (46) = happyShift action_28 +action_5 (47) = happyShift action_29 +action_5 (9) = happyGoto action_8 +action_5 (10) = happyGoto action_9 +action_5 (11) = happyGoto action_10 +action_5 (13) = happyGoto action_11 +action_5 (14) = happyGoto action_12 +action_5 (15) = happyGoto action_13 +action_5 (17) = happyGoto action_14 +action_5 _ = happyFail (happyExpListPerState 5) + +action_6 (45) = happyShift action_7 +action_6 _ = happyFail (happyExpListPerState 6) + +action_7 _ = happyReduce_6 + +action_8 _ = happyReduce_10 + +action_9 _ = happyReduce_13 + +action_10 _ = happyReduce_14 + +action_11 (22) = happyShift action_50 +action_11 _ = happyReduce_23 + +action_12 (20) = happyShift action_37 +action_12 (21) = happyShift action_38 +action_12 _ = happyReduce_33 + +action_13 (18) = happyShift action_15 +action_13 (27) = happyShift action_16 +action_13 (28) = happyShift action_17 +action_13 (29) = happyShift action_18 +action_13 (30) = happyShift action_40 +action_13 (34) = happyShift action_19 +action_13 (39) = happyShift action_23 +action_13 (42) = happyShift action_25 +action_13 (45) = happyShift action_7 +action_13 (46) = happyShift action_28 +action_13 (47) = happyShift action_29 +action_13 (9) = happyGoto action_8 +action_13 (10) = happyGoto action_9 +action_13 (11) = happyGoto action_10 +action_13 (13) = happyGoto action_11 +action_13 (14) = happyGoto action_39 +action_13 _ = happyReduce_36 + +action_14 (48) = happyAccept +action_14 _ = happyFail (happyExpListPerState 14) + +action_15 (18) = happyShift action_15 +action_15 (27) = happyShift action_16 +action_15 (28) = happyShift action_17 +action_15 (29) = happyShift action_18 +action_15 (34) = happyShift action_19 +action_15 (35) = happyShift action_20 +action_15 (36) = happyShift action_21 +action_15 (37) = happyShift action_22 +action_15 (39) = happyShift action_23 +action_15 (40) = happyShift action_24 +action_15 (42) = happyShift action_25 +action_15 (43) = happyShift action_26 +action_15 (44) = happyShift action_27 +action_15 (45) = happyShift action_7 +action_15 (46) = happyShift action_28 +action_15 (47) = happyShift action_29 +action_15 (9) = happyGoto action_8 +action_15 (10) = happyGoto action_9 +action_15 (11) = happyGoto action_10 +action_15 (13) = happyGoto action_11 +action_15 (14) = happyGoto action_12 +action_15 (15) = happyGoto action_30 +action_15 (16) = happyGoto action_49 +action_15 _ = happyFail (happyExpListPerState 15) + +action_16 _ = happyReduce_16 + +action_17 _ = happyReduce_15 + +action_18 _ = happyReduce_17 + +action_19 _ = happyReduce_12 + +action_20 (45) = happyShift action_7 +action_20 (9) = happyGoto action_35 +action_20 (12) = happyGoto action_48 +action_20 _ = happyFail (happyExpListPerState 20) + +action_21 (45) = happyShift action_7 +action_21 (9) = happyGoto action_35 +action_21 (12) = happyGoto action_47 +action_21 _ = happyFail (happyExpListPerState 21) + +action_22 (18) = happyShift action_15 +action_22 (27) = happyShift action_16 +action_22 (28) = happyShift action_17 +action_22 (29) = happyShift action_18 +action_22 (34) = happyShift action_19 +action_22 (35) = happyShift action_20 +action_22 (36) = happyShift action_21 +action_22 (37) = happyShift action_22 +action_22 (39) = happyShift action_23 +action_22 (40) = happyShift action_24 +action_22 (42) = happyShift action_25 +action_22 (43) = happyShift action_26 +action_22 (44) = happyShift action_27 +action_22 (45) = happyShift action_7 +action_22 (46) = happyShift action_28 +action_22 (47) = happyShift action_29 +action_22 (9) = happyGoto action_8 +action_22 (10) = happyGoto action_9 +action_22 (11) = happyGoto action_10 +action_22 (13) = happyGoto action_11 +action_22 (14) = happyGoto action_12 +action_22 (15) = happyGoto action_46 +action_22 _ = happyFail (happyExpListPerState 22) + +action_23 (18) = happyShift action_45 +action_23 _ = happyFail (happyExpListPerState 23) + +action_24 (45) = happyShift action_7 +action_24 (9) = happyGoto action_35 +action_24 (12) = happyGoto action_44 +action_24 _ = happyFail (happyExpListPerState 24) + +action_25 _ = happyReduce_11 + +action_26 (45) = happyShift action_7 +action_26 (9) = happyGoto action_35 +action_26 (12) = happyGoto action_43 +action_26 _ = happyFail (happyExpListPerState 26) + +action_27 (45) = happyShift action_7 +action_27 (9) = happyGoto action_35 +action_27 (12) = happyGoto action_42 +action_27 _ = happyFail (happyExpListPerState 27) + +action_28 _ = happyReduce_7 + +action_29 _ = happyReduce_8 + +action_30 (18) = happyShift action_15 +action_30 (25) = happyShift action_41 +action_30 (27) = happyShift action_16 +action_30 (28) = happyShift action_17 +action_30 (29) = happyShift action_18 +action_30 (30) = happyShift action_40 +action_30 (34) = happyShift action_19 +action_30 (39) = happyShift action_23 +action_30 (42) = happyShift action_25 +action_30 (45) = happyShift action_7 +action_30 (46) = happyShift action_28 +action_30 (47) = happyShift action_29 +action_30 (9) = happyGoto action_8 +action_30 (10) = happyGoto action_9 +action_30 (11) = happyGoto action_10 +action_30 (13) = happyGoto action_11 +action_30 (14) = happyGoto action_39 +action_30 _ = happyReduce_35 + +action_31 (48) = happyAccept +action_31 _ = happyFail (happyExpListPerState 31) + +action_32 (18) = happyShift action_15 +action_32 (27) = happyShift action_16 +action_32 (28) = happyShift action_17 +action_32 (29) = happyShift action_18 +action_32 (30) = happyShift action_40 +action_32 (34) = happyShift action_19 +action_32 (39) = happyShift action_23 +action_32 (42) = happyShift action_25 +action_32 (45) = happyShift action_7 +action_32 (46) = happyShift action_28 +action_32 (47) = happyShift action_29 +action_32 (48) = happyAccept +action_32 (9) = happyGoto action_8 +action_32 (10) = happyGoto action_9 +action_32 (11) = happyGoto action_10 +action_32 (13) = happyGoto action_11 +action_32 (14) = happyGoto action_39 +action_32 _ = happyFail (happyExpListPerState 32) + +action_33 (20) = happyShift action_37 +action_33 (21) = happyShift action_38 +action_33 (48) = happyAccept +action_33 _ = happyFail (happyExpListPerState 33) + +action_34 (48) = happyAccept +action_34 _ = happyFail (happyExpListPerState 34) + +action_35 _ = happyReduce_9 + +action_36 (48) = happyAccept +action_36 _ = happyFail (happyExpListPerState 36) + +action_37 (18) = happyShift action_15 +action_37 (27) = happyShift action_16 +action_37 (28) = happyShift action_17 +action_37 (29) = happyShift action_18 +action_37 (34) = happyShift action_19 +action_37 (42) = happyShift action_25 +action_37 (45) = happyShift action_7 +action_37 (46) = happyShift action_28 +action_37 (47) = happyShift action_29 +action_37 (9) = happyGoto action_8 +action_37 (10) = happyGoto action_9 +action_37 (11) = happyGoto action_10 +action_37 (13) = happyGoto action_64 +action_37 _ = happyFail (happyExpListPerState 37) + +action_38 (18) = happyShift action_15 +action_38 (27) = happyShift action_16 +action_38 (28) = happyShift action_17 +action_38 (29) = happyShift action_18 +action_38 (34) = happyShift action_19 +action_38 (42) = happyShift action_25 +action_38 (45) = happyShift action_7 +action_38 (46) = happyShift action_28 +action_38 (47) = happyShift action_29 +action_38 (9) = happyGoto action_8 +action_38 (10) = happyGoto action_9 +action_38 (11) = happyGoto action_10 +action_38 (13) = happyGoto action_63 +action_38 _ = happyFail (happyExpListPerState 38) + +action_39 (20) = happyShift action_37 +action_39 (21) = happyShift action_38 +action_39 _ = happyReduce_28 + +action_40 (18) = happyShift action_15 +action_40 (27) = happyShift action_16 +action_40 (28) = happyShift action_17 +action_40 (29) = happyShift action_18 +action_40 (34) = happyShift action_19 +action_40 (35) = happyShift action_20 +action_40 (36) = happyShift action_21 +action_40 (37) = happyShift action_22 +action_40 (39) = happyShift action_23 +action_40 (40) = happyShift action_24 +action_40 (42) = happyShift action_25 +action_40 (43) = happyShift action_26 +action_40 (44) = happyShift action_27 +action_40 (45) = happyShift action_7 +action_40 (46) = happyShift action_28 +action_40 (47) = happyShift action_29 +action_40 (9) = happyGoto action_8 +action_40 (10) = happyGoto action_9 +action_40 (11) = happyGoto action_10 +action_40 (13) = happyGoto action_11 +action_40 (14) = happyGoto action_12 +action_40 (15) = happyGoto action_30 +action_40 (16) = happyGoto action_62 +action_40 _ = happyFail (happyExpListPerState 40) + +action_41 (18) = happyShift action_15 +action_41 (27) = happyShift action_16 +action_41 (28) = happyShift action_17 +action_41 (29) = happyShift action_18 +action_41 (34) = happyShift action_19 +action_41 (35) = happyShift action_20 +action_41 (36) = happyShift action_21 +action_41 (37) = happyShift action_22 +action_41 (39) = happyShift action_23 +action_41 (40) = happyShift action_24 +action_41 (42) = happyShift action_25 +action_41 (43) = happyShift action_26 +action_41 (44) = happyShift action_27 +action_41 (45) = happyShift action_7 +action_41 (46) = happyShift action_28 +action_41 (47) = happyShift action_29 +action_41 (9) = happyGoto action_8 +action_41 (10) = happyGoto action_9 +action_41 (11) = happyGoto action_10 +action_41 (13) = happyGoto action_11 +action_41 (14) = happyGoto action_12 +action_41 (15) = happyGoto action_30 +action_41 (16) = happyGoto action_61 +action_41 _ = happyFail (happyExpListPerState 41) + +action_42 (23) = happyShift action_59 +action_42 (25) = happyShift action_60 +action_42 _ = happyFail (happyExpListPerState 42) + +action_43 (23) = happyShift action_58 +action_43 _ = happyFail (happyExpListPerState 43) + +action_44 (26) = happyShift action_57 +action_44 _ = happyFail (happyExpListPerState 44) + +action_45 (18) = happyShift action_15 +action_45 (27) = happyShift action_16 +action_45 (28) = happyShift action_17 +action_45 (29) = happyShift action_18 +action_45 (34) = happyShift action_19 +action_45 (35) = happyShift action_20 +action_45 (36) = happyShift action_21 +action_45 (37) = happyShift action_22 +action_45 (39) = happyShift action_23 +action_45 (40) = happyShift action_24 +action_45 (42) = happyShift action_25 +action_45 (43) = happyShift action_26 +action_45 (44) = happyShift action_27 +action_45 (45) = happyShift action_7 +action_45 (46) = happyShift action_28 +action_45 (47) = happyShift action_29 +action_45 (9) = happyGoto action_8 +action_45 (10) = happyGoto action_9 +action_45 (11) = happyGoto action_10 +action_45 (13) = happyGoto action_11 +action_45 (14) = happyGoto action_12 +action_45 (15) = happyGoto action_30 +action_45 (16) = happyGoto action_56 +action_45 _ = happyFail (happyExpListPerState 45) + +action_46 (18) = happyShift action_15 +action_46 (27) = happyShift action_16 +action_46 (28) = happyShift action_17 +action_46 (29) = happyShift action_18 +action_46 (30) = happyShift action_40 +action_46 (34) = happyShift action_19 +action_46 (39) = happyShift action_23 +action_46 (41) = happyShift action_55 +action_46 (42) = happyShift action_25 +action_46 (45) = happyShift action_7 +action_46 (46) = happyShift action_28 +action_46 (47) = happyShift action_29 +action_46 (9) = happyGoto action_8 +action_46 (10) = happyGoto action_9 +action_46 (11) = happyGoto action_10 +action_46 (13) = happyGoto action_11 +action_46 (14) = happyGoto action_39 +action_46 _ = happyFail (happyExpListPerState 46) + +action_47 (23) = happyShift action_54 +action_47 _ = happyFail (happyExpListPerState 47) + +action_48 (38) = happyShift action_53 +action_48 _ = happyFail (happyExpListPerState 48) + +action_49 (19) = happyShift action_52 +action_49 _ = happyFail (happyExpListPerState 49) + +action_50 (18) = happyShift action_15 +action_50 (27) = happyShift action_16 +action_50 (28) = happyShift action_17 +action_50 (29) = happyShift action_18 +action_50 (34) = happyShift action_19 +action_50 (39) = happyShift action_23 +action_50 (42) = happyShift action_25 +action_50 (45) = happyShift action_7 +action_50 (46) = happyShift action_28 +action_50 (47) = happyShift action_29 +action_50 (9) = happyGoto action_8 +action_50 (10) = happyGoto action_9 +action_50 (11) = happyGoto action_10 +action_50 (13) = happyGoto action_11 +action_50 (14) = happyGoto action_51 +action_50 _ = happyFail (happyExpListPerState 50) + +action_51 (20) = happyShift action_37 +action_51 (21) = happyShift action_38 +action_51 _ = happyReduce_22 + +action_52 _ = happyReduce_18 + +action_53 (30) = happyShift action_73 +action_53 _ = happyFail (happyExpListPerState 53) + +action_54 (18) = happyShift action_15 +action_54 (27) = happyShift action_16 +action_54 (28) = happyShift action_17 +action_54 (29) = happyShift action_18 +action_54 (34) = happyShift action_19 +action_54 (35) = happyShift action_20 +action_54 (36) = happyShift action_21 +action_54 (37) = happyShift action_22 +action_54 (39) = happyShift action_23 +action_54 (40) = happyShift action_24 +action_54 (42) = happyShift action_25 +action_54 (43) = happyShift action_26 +action_54 (44) = happyShift action_27 +action_54 (45) = happyShift action_7 +action_54 (46) = happyShift action_28 +action_54 (47) = happyShift action_29 +action_54 (9) = happyGoto action_8 +action_54 (10) = happyGoto action_9 +action_54 (11) = happyGoto action_10 +action_54 (13) = happyGoto action_11 +action_54 (14) = happyGoto action_12 +action_54 (15) = happyGoto action_13 +action_54 (17) = happyGoto action_72 +action_54 _ = happyFail (happyExpListPerState 54) + +action_55 (18) = happyShift action_15 +action_55 (27) = happyShift action_16 +action_55 (28) = happyShift action_17 +action_55 (29) = happyShift action_18 +action_55 (34) = happyShift action_19 +action_55 (35) = happyShift action_20 +action_55 (36) = happyShift action_21 +action_55 (37) = happyShift action_22 +action_55 (39) = happyShift action_23 +action_55 (40) = happyShift action_24 +action_55 (42) = happyShift action_25 +action_55 (43) = happyShift action_26 +action_55 (44) = happyShift action_27 +action_55 (45) = happyShift action_7 +action_55 (46) = happyShift action_28 +action_55 (47) = happyShift action_29 +action_55 (9) = happyGoto action_8 +action_55 (10) = happyGoto action_9 +action_55 (11) = happyGoto action_10 +action_55 (13) = happyGoto action_11 +action_55 (14) = happyGoto action_12 +action_55 (15) = happyGoto action_71 +action_55 _ = happyFail (happyExpListPerState 55) + +action_56 (19) = happyShift action_70 +action_56 _ = happyFail (happyExpListPerState 56) + +action_57 (18) = happyShift action_15 +action_57 (27) = happyShift action_16 +action_57 (28) = happyShift action_17 +action_57 (29) = happyShift action_18 +action_57 (34) = happyShift action_19 +action_57 (35) = happyShift action_20 +action_57 (36) = happyShift action_21 +action_57 (37) = happyShift action_22 +action_57 (39) = happyShift action_23 +action_57 (40) = happyShift action_24 +action_57 (42) = happyShift action_25 +action_57 (43) = happyShift action_26 +action_57 (44) = happyShift action_27 +action_57 (45) = happyShift action_7 +action_57 (46) = happyShift action_28 +action_57 (47) = happyShift action_29 +action_57 (9) = happyGoto action_8 +action_57 (10) = happyGoto action_9 +action_57 (11) = happyGoto action_10 +action_57 (13) = happyGoto action_11 +action_57 (14) = happyGoto action_12 +action_57 (15) = happyGoto action_69 +action_57 _ = happyFail (happyExpListPerState 57) + +action_58 (18) = happyShift action_15 +action_58 (27) = happyShift action_16 +action_58 (28) = happyShift action_17 +action_58 (29) = happyShift action_18 +action_58 (34) = happyShift action_19 +action_58 (35) = happyShift action_20 +action_58 (36) = happyShift action_21 +action_58 (37) = happyShift action_22 +action_58 (39) = happyShift action_23 +action_58 (40) = happyShift action_24 +action_58 (42) = happyShift action_25 +action_58 (43) = happyShift action_26 +action_58 (44) = happyShift action_27 +action_58 (45) = happyShift action_7 +action_58 (46) = happyShift action_28 +action_58 (47) = happyShift action_29 +action_58 (9) = happyGoto action_8 +action_58 (10) = happyGoto action_9 +action_58 (11) = happyGoto action_10 +action_58 (13) = happyGoto action_11 +action_58 (14) = happyGoto action_12 +action_58 (15) = happyGoto action_13 +action_58 (17) = happyGoto action_68 +action_58 _ = happyFail (happyExpListPerState 58) + +action_59 (18) = happyShift action_15 +action_59 (27) = happyShift action_16 +action_59 (28) = happyShift action_17 +action_59 (29) = happyShift action_18 +action_59 (34) = happyShift action_19 +action_59 (35) = happyShift action_20 +action_59 (36) = happyShift action_21 +action_59 (37) = happyShift action_22 +action_59 (39) = happyShift action_23 +action_59 (40) = happyShift action_24 +action_59 (42) = happyShift action_25 +action_59 (43) = happyShift action_26 +action_59 (44) = happyShift action_27 +action_59 (45) = happyShift action_7 +action_59 (46) = happyShift action_28 +action_59 (47) = happyShift action_29 +action_59 (9) = happyGoto action_8 +action_59 (10) = happyGoto action_9 +action_59 (11) = happyGoto action_10 +action_59 (13) = happyGoto action_11 +action_59 (14) = happyGoto action_12 +action_59 (15) = happyGoto action_13 +action_59 (17) = happyGoto action_67 +action_59 _ = happyFail (happyExpListPerState 59) + +action_60 (18) = happyShift action_15 +action_60 (27) = happyShift action_16 +action_60 (28) = happyShift action_17 +action_60 (29) = happyShift action_18 +action_60 (34) = happyShift action_19 +action_60 (35) = happyShift action_20 +action_60 (36) = happyShift action_21 +action_60 (37) = happyShift action_22 +action_60 (39) = happyShift action_23 +action_60 (40) = happyShift action_24 +action_60 (42) = happyShift action_25 +action_60 (43) = happyShift action_26 +action_60 (44) = happyShift action_27 +action_60 (45) = happyShift action_7 +action_60 (46) = happyShift action_28 +action_60 (47) = happyShift action_29 +action_60 (9) = happyGoto action_8 +action_60 (10) = happyGoto action_9 +action_60 (11) = happyGoto action_10 +action_60 (13) = happyGoto action_11 +action_60 (14) = happyGoto action_12 +action_60 (15) = happyGoto action_30 +action_60 (16) = happyGoto action_66 +action_60 _ = happyFail (happyExpListPerState 60) + +action_61 _ = happyReduce_34 + +action_62 (31) = happyShift action_65 +action_62 _ = happyFail (happyExpListPerState 62) + +action_63 _ = happyReduce_20 + +action_64 _ = happyReduce_19 + +action_65 _ = happyReduce_30 + +action_66 (23) = happyShift action_77 +action_66 _ = happyFail (happyExpListPerState 66) + +action_67 _ = happyReduce_27 + +action_68 _ = happyReduce_29 + +action_69 (18) = happyShift action_15 +action_69 (27) = happyShift action_16 +action_69 (28) = happyShift action_17 +action_69 (29) = happyShift action_18 +action_69 (30) = happyShift action_40 +action_69 (34) = happyShift action_19 +action_69 (38) = happyShift action_76 +action_69 (39) = happyShift action_23 +action_69 (42) = happyShift action_25 +action_69 (45) = happyShift action_7 +action_69 (46) = happyShift action_28 +action_69 (47) = happyShift action_29 +action_69 (9) = happyGoto action_8 +action_69 (10) = happyGoto action_9 +action_69 (11) = happyGoto action_10 +action_69 (13) = happyGoto action_11 +action_69 (14) = happyGoto action_39 +action_69 _ = happyFail (happyExpListPerState 69) + +action_70 _ = happyReduce_21 + +action_71 (18) = happyShift action_15 +action_71 (27) = happyShift action_16 +action_71 (28) = happyShift action_17 +action_71 (29) = happyShift action_18 +action_71 (30) = happyShift action_40 +action_71 (33) = happyShift action_75 +action_71 (34) = happyShift action_19 +action_71 (39) = happyShift action_23 +action_71 (42) = happyShift action_25 +action_71 (45) = happyShift action_7 +action_71 (46) = happyShift action_28 +action_71 (47) = happyShift action_29 +action_71 (9) = happyGoto action_8 +action_71 (10) = happyGoto action_9 +action_71 (11) = happyGoto action_10 +action_71 (13) = happyGoto action_11 +action_71 (14) = happyGoto action_39 +action_71 _ = happyFail (happyExpListPerState 71) + +action_72 _ = happyReduce_32 + +action_73 (18) = happyShift action_15 +action_73 (27) = happyShift action_16 +action_73 (28) = happyShift action_17 +action_73 (29) = happyShift action_18 +action_73 (34) = happyShift action_19 +action_73 (35) = happyShift action_20 +action_73 (36) = happyShift action_21 +action_73 (37) = happyShift action_22 +action_73 (39) = happyShift action_23 +action_73 (40) = happyShift action_24 +action_73 (42) = happyShift action_25 +action_73 (43) = happyShift action_26 +action_73 (44) = happyShift action_27 +action_73 (45) = happyShift action_7 +action_73 (46) = happyShift action_28 +action_73 (47) = happyShift action_29 +action_73 (9) = happyGoto action_8 +action_73 (10) = happyGoto action_9 +action_73 (11) = happyGoto action_10 +action_73 (13) = happyGoto action_11 +action_73 (14) = happyGoto action_12 +action_73 (15) = happyGoto action_74 +action_73 _ = happyFail (happyExpListPerState 73) + +action_74 (18) = happyShift action_15 +action_74 (24) = happyShift action_81 +action_74 (27) = happyShift action_16 +action_74 (28) = happyShift action_17 +action_74 (29) = happyShift action_18 +action_74 (30) = happyShift action_40 +action_74 (34) = happyShift action_19 +action_74 (39) = happyShift action_23 +action_74 (42) = happyShift action_25 +action_74 (45) = happyShift action_7 +action_74 (46) = happyShift action_28 +action_74 (47) = happyShift action_29 +action_74 (9) = happyGoto action_8 +action_74 (10) = happyGoto action_9 +action_74 (11) = happyGoto action_10 +action_74 (13) = happyGoto action_11 +action_74 (14) = happyGoto action_39 +action_74 _ = happyFail (happyExpListPerState 74) + +action_75 (18) = happyShift action_15 +action_75 (27) = happyShift action_16 +action_75 (28) = happyShift action_17 +action_75 (29) = happyShift action_18 +action_75 (34) = happyShift action_19 +action_75 (35) = happyShift action_20 +action_75 (36) = happyShift action_21 +action_75 (37) = happyShift action_22 +action_75 (39) = happyShift action_23 +action_75 (40) = happyShift action_24 +action_75 (42) = happyShift action_25 +action_75 (43) = happyShift action_26 +action_75 (44) = happyShift action_27 +action_75 (45) = happyShift action_7 +action_75 (46) = happyShift action_28 +action_75 (47) = happyShift action_29 +action_75 (9) = happyGoto action_8 +action_75 (10) = happyGoto action_9 +action_75 (11) = happyGoto action_10 +action_75 (13) = happyGoto action_11 +action_75 (14) = happyGoto action_12 +action_75 (15) = happyGoto action_80 +action_75 _ = happyFail (happyExpListPerState 75) + +action_76 (18) = happyShift action_15 +action_76 (27) = happyShift action_16 +action_76 (28) = happyShift action_17 +action_76 (29) = happyShift action_18 +action_76 (34) = happyShift action_19 +action_76 (35) = happyShift action_20 +action_76 (36) = happyShift action_21 +action_76 (37) = happyShift action_22 +action_76 (39) = happyShift action_23 +action_76 (40) = happyShift action_24 +action_76 (42) = happyShift action_25 +action_76 (43) = happyShift action_26 +action_76 (44) = happyShift action_27 +action_76 (45) = happyShift action_7 +action_76 (46) = happyShift action_28 +action_76 (47) = happyShift action_29 +action_76 (9) = happyGoto action_8 +action_76 (10) = happyGoto action_9 +action_76 (11) = happyGoto action_10 +action_76 (13) = happyGoto action_11 +action_76 (14) = happyGoto action_12 +action_76 (15) = happyGoto action_13 +action_76 (17) = happyGoto action_79 +action_76 _ = happyFail (happyExpListPerState 76) + +action_77 (18) = happyShift action_15 +action_77 (27) = happyShift action_16 +action_77 (28) = happyShift action_17 +action_77 (29) = happyShift action_18 +action_77 (34) = happyShift action_19 +action_77 (35) = happyShift action_20 +action_77 (36) = happyShift action_21 +action_77 (37) = happyShift action_22 +action_77 (39) = happyShift action_23 +action_77 (40) = happyShift action_24 +action_77 (42) = happyShift action_25 +action_77 (43) = happyShift action_26 +action_77 (44) = happyShift action_27 +action_77 (45) = happyShift action_7 +action_77 (46) = happyShift action_28 +action_77 (47) = happyShift action_29 +action_77 (9) = happyGoto action_8 +action_77 (10) = happyGoto action_9 +action_77 (11) = happyGoto action_10 +action_77 (13) = happyGoto action_11 +action_77 (14) = happyGoto action_12 +action_77 (15) = happyGoto action_13 +action_77 (17) = happyGoto action_78 +action_77 _ = happyFail (happyExpListPerState 77) + +action_78 _ = happyReduce_26 + +action_79 _ = happyReduce_25 + +action_80 (18) = happyShift action_15 +action_80 (27) = happyShift action_16 +action_80 (28) = happyShift action_17 +action_80 (29) = happyShift action_18 +action_80 (30) = happyShift action_40 +action_80 (34) = happyShift action_19 +action_80 (39) = happyShift action_23 +action_80 (42) = happyShift action_25 +action_80 (45) = happyShift action_7 +action_80 (46) = happyShift action_28 +action_80 (47) = happyShift action_29 +action_80 (9) = happyGoto action_8 +action_80 (10) = happyGoto action_9 +action_80 (11) = happyGoto action_10 +action_80 (13) = happyGoto action_11 +action_80 (14) = happyGoto action_39 +action_80 _ = happyReduce_24 + +action_81 (18) = happyShift action_15 +action_81 (27) = happyShift action_16 +action_81 (28) = happyShift action_17 +action_81 (29) = happyShift action_18 +action_81 (34) = happyShift action_19 +action_81 (35) = happyShift action_20 +action_81 (36) = happyShift action_21 +action_81 (37) = happyShift action_22 +action_81 (39) = happyShift action_23 +action_81 (40) = happyShift action_24 +action_81 (42) = happyShift action_25 +action_81 (43) = happyShift action_26 +action_81 (44) = happyShift action_27 +action_81 (45) = happyShift action_7 +action_81 (46) = happyShift action_28 +action_81 (47) = happyShift action_29 +action_81 (9) = happyGoto action_8 +action_81 (10) = happyGoto action_9 +action_81 (11) = happyGoto action_10 +action_81 (13) = happyGoto action_11 +action_81 (14) = happyGoto action_12 +action_81 (15) = happyGoto action_82 +action_81 _ = happyFail (happyExpListPerState 81) + +action_82 (18) = happyShift action_15 +action_82 (27) = happyShift action_16 +action_82 (28) = happyShift action_17 +action_82 (29) = happyShift action_18 +action_82 (30) = happyShift action_40 +action_82 (31) = happyShift action_83 +action_82 (34) = happyShift action_19 +action_82 (39) = happyShift action_23 +action_82 (42) = happyShift action_25 +action_82 (45) = happyShift action_7 +action_82 (46) = happyShift action_28 +action_82 (47) = happyShift action_29 +action_82 (9) = happyGoto action_8 +action_82 (10) = happyGoto action_9 +action_82 (11) = happyGoto action_10 +action_82 (13) = happyGoto action_11 +action_82 (14) = happyGoto action_39 +action_82 _ = happyFail (happyExpListPerState 82) + +action_83 (32) = happyShift action_84 +action_83 _ = happyFail (happyExpListPerState 83) + +action_84 (18) = happyShift action_15 +action_84 (27) = happyShift action_16 +action_84 (28) = happyShift action_17 +action_84 (29) = happyShift action_18 +action_84 (34) = happyShift action_19 +action_84 (35) = happyShift action_20 +action_84 (36) = happyShift action_21 +action_84 (37) = happyShift action_22 +action_84 (39) = happyShift action_23 +action_84 (40) = happyShift action_24 +action_84 (42) = happyShift action_25 +action_84 (43) = happyShift action_26 +action_84 (44) = happyShift action_27 +action_84 (45) = happyShift action_7 +action_84 (46) = happyShift action_28 +action_84 (47) = happyShift action_29 +action_84 (9) = happyGoto action_8 +action_84 (10) = happyGoto action_9 +action_84 (11) = happyGoto action_10 +action_84 (13) = happyGoto action_11 +action_84 (14) = happyGoto action_12 +action_84 (15) = happyGoto action_13 +action_84 (17) = happyGoto action_85 +action_84 _ = happyFail (happyExpListPerState 84) + +action_85 _ = happyReduce_31 + +happyReduce_6 = happySpecReduce_1 9 happyReduction_6 +happyReduction_6 (HappyTerminal (PT _ (TV happy_var_1))) + = HappyAbsSyn9 + (FreeFoilTypecheck.SystemF.Parser.Abs.Ident happy_var_1 + ) +happyReduction_6 _ = notHappyAtAll + +happyReduce_7 = happySpecReduce_1 10 happyReduction_7 +happyReduction_7 (HappyTerminal (PT _ (TI happy_var_1))) + = HappyAbsSyn10 + ((read happy_var_1) :: Integer + ) +happyReduction_7 _ = notHappyAtAll + +happyReduce_8 = happySpecReduce_1 11 happyReduction_8 +happyReduction_8 (HappyTerminal (PT _ (T_UVarIdent happy_var_1))) + = HappyAbsSyn11 + (FreeFoilTypecheck.SystemF.Parser.Abs.UVarIdent happy_var_1 + ) +happyReduction_8 _ = notHappyAtAll + +happyReduce_9 = happySpecReduce_1 12 happyReduction_9 +happyReduction_9 (HappyAbsSyn9 happy_var_1) + = HappyAbsSyn12 + (FreeFoilTypecheck.SystemF.Parser.Abs.PatternVar happy_var_1 + ) +happyReduction_9 _ = notHappyAtAll + +happyReduce_10 = happySpecReduce_1 13 happyReduction_10 +happyReduction_10 (HappyAbsSyn9 happy_var_1) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.EVar happy_var_1 + ) +happyReduction_10 _ = notHappyAtAll + +happyReduce_11 = happySpecReduce_1 13 happyReduction_11 +happyReduction_11 _ + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.ETrue + ) + +happyReduce_12 = happySpecReduce_1 13 happyReduction_12 +happyReduction_12 _ + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.EFalse + ) + +happyReduce_13 = happySpecReduce_1 13 happyReduction_13 +happyReduction_13 (HappyAbsSyn10 happy_var_1) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.ENat happy_var_1 + ) +happyReduction_13 _ = notHappyAtAll + +happyReduce_14 = happySpecReduce_1 13 happyReduction_14 +happyReduction_14 (HappyAbsSyn11 happy_var_1) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.TUVar happy_var_1 + ) +happyReduction_14 _ = notHappyAtAll + +happyReduce_15 = happySpecReduce_1 13 happyReduction_15 +happyReduction_15 _ + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.TNat + ) + +happyReduce_16 = happySpecReduce_1 13 happyReduction_16 +happyReduction_16 _ + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.TBool + ) + +happyReduce_17 = happySpecReduce_1 13 happyReduction_17 +happyReduction_17 _ + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.TType + ) + +happyReduce_18 = happySpecReduce_3 13 happyReduction_18 +happyReduction_18 _ + (HappyAbsSyn13 happy_var_2) + _ + = HappyAbsSyn13 + (happy_var_2 + ) +happyReduction_18 _ _ _ = notHappyAtAll + +happyReduce_19 = happySpecReduce_3 14 happyReduction_19 +happyReduction_19 (HappyAbsSyn13 happy_var_3) + _ + (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.EAdd happy_var_1 happy_var_3 + ) +happyReduction_19 _ _ _ = notHappyAtAll + +happyReduce_20 = happySpecReduce_3 14 happyReduction_20 +happyReduction_20 (HappyAbsSyn13 happy_var_3) + _ + (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.ESub happy_var_1 happy_var_3 + ) +happyReduction_20 _ _ _ = notHappyAtAll + +happyReduce_21 = happyReduce 4 14 happyReduction_21 +happyReduction_21 (_ `HappyStk` + (HappyAbsSyn13 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.EIsZero happy_var_3 + ) `HappyStk` happyRest + +happyReduce_22 = happySpecReduce_3 14 happyReduction_22 +happyReduction_22 (HappyAbsSyn13 happy_var_3) + _ + (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.TArrow happy_var_1 happy_var_3 + ) +happyReduction_22 _ _ _ = notHappyAtAll + +happyReduce_23 = happySpecReduce_1 14 happyReduction_23 +happyReduction_23 (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (happy_var_1 + ) +happyReduction_23 _ = notHappyAtAll + +happyReduce_24 = happyReduce 6 15 happyReduction_24 +happyReduction_24 ((HappyAbsSyn13 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn13 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn13 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.EIf happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest + +happyReduce_25 = happyReduce 6 15 happyReduction_25 +happyReduction_25 ((HappyAbsSyn17 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn13 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn12 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.ELet happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest + +happyReduce_26 = happyReduce 6 15 happyReduction_26 +happyReduction_26 ((HappyAbsSyn17 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn13 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn12 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.EAbsTyped happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest + +happyReduce_27 = happyReduce 4 15 happyReduction_27 +happyReduction_27 ((HappyAbsSyn17 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn12 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.EAbsUntyped happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_28 = happySpecReduce_2 15 happyReduction_28 +happyReduction_28 (HappyAbsSyn13 happy_var_2) + (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.EApp happy_var_1 happy_var_2 + ) +happyReduction_28 _ _ = notHappyAtAll + +happyReduce_29 = happyReduce 4 15 happyReduction_29 +happyReduction_29 ((HappyAbsSyn17 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn12 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.ETAbs happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_30 = happyReduce 4 15 happyReduction_30 +happyReduction_30 (_ `HappyStk` + (HappyAbsSyn13 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyAbsSyn13 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.ETApp happy_var_1 happy_var_3 + ) `HappyStk` happyRest + +happyReduce_31 = happyReduce 10 15 happyReduction_31 +happyReduction_31 ((HappyAbsSyn17 happy_var_10) `HappyStk` + _ `HappyStk` + _ `HappyStk` + (HappyAbsSyn13 happy_var_7) `HappyStk` + _ `HappyStk` + (HappyAbsSyn13 happy_var_5) `HappyStk` + _ `HappyStk` + _ `HappyStk` + (HappyAbsSyn12 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.EFor happy_var_2 happy_var_5 happy_var_7 happy_var_10 + ) `HappyStk` happyRest + +happyReduce_32 = happyReduce 4 15 happyReduction_32 +happyReduction_32 ((HappyAbsSyn17 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn12 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.TForAll happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_33 = happySpecReduce_1 15 happyReduction_33 +happyReduction_33 (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (happy_var_1 + ) +happyReduction_33 _ = notHappyAtAll + +happyReduce_34 = happySpecReduce_3 16 happyReduction_34 +happyReduction_34 (HappyAbsSyn13 happy_var_3) + _ + (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (FreeFoilTypecheck.SystemF.Parser.Abs.ETyped happy_var_1 happy_var_3 + ) +happyReduction_34 _ _ _ = notHappyAtAll + +happyReduce_35 = happySpecReduce_1 16 happyReduction_35 +happyReduction_35 (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (happy_var_1 + ) +happyReduction_35 _ = notHappyAtAll + +happyReduce_36 = happySpecReduce_1 17 happyReduction_36 +happyReduction_36 (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn17 + (FreeFoilTypecheck.SystemF.Parser.Abs.ScopedTerm happy_var_1 + ) +happyReduction_36 _ = notHappyAtAll + +happyNewToken action sts stk [] = + action 48 48 notHappyAtAll (HappyState action) sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = action i i tk (HappyState action) sts stk tks in + case tk of { + PT _ (TS _ 1) -> cont 18; + PT _ (TS _ 2) -> cont 19; + PT _ (TS _ 3) -> cont 20; + PT _ (TS _ 4) -> cont 21; + PT _ (TS _ 5) -> cont 22; + PT _ (TS _ 6) -> cont 23; + PT _ (TS _ 7) -> cont 24; + PT _ (TS _ 8) -> cont 25; + PT _ (TS _ 9) -> cont 26; + PT _ (TS _ 10) -> cont 27; + PT _ (TS _ 11) -> cont 28; + PT _ (TS _ 12) -> cont 29; + PT _ (TS _ 13) -> cont 30; + PT _ (TS _ 14) -> cont 31; + PT _ (TS _ 15) -> cont 32; + PT _ (TS _ 16) -> cont 33; + PT _ (TS _ 17) -> cont 34; + PT _ (TS _ 18) -> cont 35; + PT _ (TS _ 19) -> cont 36; + PT _ (TS _ 20) -> cont 37; + PT _ (TS _ 21) -> cont 38; + PT _ (TS _ 22) -> cont 39; + PT _ (TS _ 23) -> cont 40; + PT _ (TS _ 24) -> cont 41; + PT _ (TS _ 25) -> cont 42; + PT _ (TS _ 26) -> cont 43; + PT _ (TS _ 27) -> cont 44; + PT _ (TV happy_dollar_dollar) -> cont 45; + PT _ (TI happy_dollar_dollar) -> cont 46; + PT _ (T_UVarIdent happy_dollar_dollar) -> cont 47; + _ -> happyError' ((tk:tks), []) + } + +happyError_ explist 48 tk tks = happyError' (tks, explist) +happyError_ explist _ tk tks = happyError' ((tk:tks), explist) + +happyThen :: () => Err a -> (a -> Err b) -> Err b +happyThen = ((>>=)) +happyReturn :: () => a -> Err a +happyReturn = (return) +happyThen1 m k tks = ((>>=)) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> Err a +happyReturn1 = \a tks -> (return) a +happyError' :: () => ([(Token)], [Prelude.String]) -> Err a +happyError' = (\(tokens, _) -> happyError tokens) +pPattern tks = happySomeParser where + happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn12 z -> happyReturn z; _other -> notHappyAtAll }) + +pTerm3 tks = happySomeParser where + happySomeParser = happyThen (happyParse action_1 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) + +pTerm2 tks = happySomeParser where + happySomeParser = happyThen (happyParse action_2 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) + +pTerm1 tks = happySomeParser where + happySomeParser = happyThen (happyParse action_3 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) + +pTerm tks = happySomeParser where + happySomeParser = happyThen (happyParse action_4 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) + +pScopedTerm tks = happySomeParser where + happySomeParser = happyThen (happyParse action_5 tks) (\x -> case x of {HappyAbsSyn17 z -> happyReturn z; _other -> notHappyAtAll }) + +happySeq = happyDontSeq + + +type Err = Either String + +happyError :: [Token] -> Err a +happyError ts = Left $ + "syntax error at " ++ tokenPos ts ++ + case ts of + [] -> [] + [Err _] -> " due to lexer error" + t:_ -> " before `" ++ (prToken t) ++ "'" + +myLexer :: String -> [Token] +myLexer = tokens +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +data Happy_IntList = HappyCons Prelude.Int Happy_IntList + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is ERROR_TOK, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +indexShortOffAddr arr off = arr Happy_Data_Array.! off + + +{-# INLINE happyLt #-} +happyLt x y = (x Prelude.< y) + + + + + + +readArrayBit arr bit = + Bits.testBit (indexShortOffAddr arr (bit `Prelude.div` 16)) (bit `Prelude.mod` 16) + + + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + + + +newtype HappyState b c = HappyState + (Prelude.Int -> -- token number + Prelude.Int -> -- token number (yes, again) + b -> -- token semantic value + HappyState b c -> -- current state + [HappyState b c] -> -- state stack + c) + + + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state (1) tk st sts stk@(x `HappyStk` _) = + let i = (case x of { HappyErrorToken (i) -> i }) in +-- trace "shifting the error token" $ + new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk + = action nt j tk st ((st):(sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Prelude.- ((1) :: Prelude.Int)) sts of + sts1@(((st1@(HappyState (action))):(_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (action nt j tk st1 sts1 r) + +happyMonadReduce k nt fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + case happyDrop k ((st):(sts)) of + sts1@(((st1@(HappyState (action))):(_))) -> + let drop_stk = happyDropStk k stk in + happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) + +happyMonad2Reduce k nt fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + case happyDrop k ((st):(sts)) of + sts1@(((st1@(HappyState (action))):(_))) -> + let drop_stk = happyDropStk k stk + + + + + + _ = nt :: Prelude.Int + new_state = action + + in + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + +happyDrop (0) l = l +happyDrop n ((_):(t)) = happyDrop (n Prelude.- ((1) :: Prelude.Int)) t + +happyDropStk (0) l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Prelude.- ((1)::Prelude.Int)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + + + + + + + + +happyGoto action j tk st = action j j tk (HappyState action) + + +----------------------------------------------------------------------------- +-- Error recovery (ERROR_TOK is the error token) + +-- parse error if we are in recovery and we fail again +happyFail explist (1) tk old_st _ stk@(x `HappyStk` _) = + let i = (case x of { HappyErrorToken (i) -> i }) in +-- trace "failing" $ + happyError_ explist i tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail explist i tk (HappyState (action)) sts stk = +-- trace "entering error recovery" $ + action (1) (1) tk (HappyState (action)) sts ((HappyErrorToken (i)) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = Prelude.error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + + + + + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `Prelude.seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + + + + + + + + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src/FreeFoilTypecheck/SystemF/Parser/Par.y b/src/FreeFoilTypecheck/SystemF/Parser/Par.y new file mode 100644 index 0000000..50d69f1 --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Parser/Par.y @@ -0,0 +1,140 @@ +-- -*- haskell -*- File generated by the BNF Converter (bnfc 2.9.5). + +-- Parser definition for use with Happy +{ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module FreeFoilTypecheck.SystemF.Parser.Par + ( happyError + , myLexer + , pPattern + , pTerm3 + , pTerm2 + , pTerm1 + , pTerm + , pScopedTerm + ) where + +import Prelude + +import qualified FreeFoilTypecheck.SystemF.Parser.Abs +import FreeFoilTypecheck.SystemF.Parser.Lex + +} + +%name pPattern Pattern +%name pTerm3 Term3 +%name pTerm2 Term2 +%name pTerm1 Term1 +%name pTerm Term +%name pScopedTerm ScopedTerm +-- no lexer declaration +%monad { Err } { (>>=) } { return } +%tokentype {Token} +%token + '(' { PT _ (TS _ 1) } + ')' { PT _ (TS _ 2) } + '+' { PT _ (TS _ 3) } + '-' { PT _ (TS _ 4) } + '->' { PT _ (TS _ 5) } + '.' { PT _ (TS _ 6) } + '..' { PT _ (TS _ 7) } + ':' { PT _ (TS _ 8) } + '=' { PT _ (TS _ 9) } + 'Bool' { PT _ (TS _ 10) } + 'Nat' { PT _ (TS _ 11) } + 'Type' { PT _ (TS _ 12) } + '[' { PT _ (TS _ 13) } + ']' { PT _ (TS _ 14) } + 'do' { PT _ (TS _ 15) } + 'else' { PT _ (TS _ 16) } + 'false' { PT _ (TS _ 17) } + 'for' { PT _ (TS _ 18) } + 'forall' { PT _ (TS _ 19) } + 'if' { PT _ (TS _ 20) } + 'in' { PT _ (TS _ 21) } + 'iszero' { PT _ (TS _ 22) } + 'let' { PT _ (TS _ 23) } + 'then' { PT _ (TS _ 24) } + 'true' { PT _ (TS _ 25) } + 'Λ' { PT _ (TS _ 26) } + 'λ' { PT _ (TS _ 27) } + L_Ident { PT _ (TV $$) } + L_integ { PT _ (TI $$) } + L_UVarIdent { PT _ (T_UVarIdent $$) } + +%% + +Ident :: { FreeFoilTypecheck.SystemF.Parser.Abs.Ident } +Ident : L_Ident { FreeFoilTypecheck.SystemF.Parser.Abs.Ident $1 } + +Integer :: { Integer } +Integer : L_integ { (read $1) :: Integer } + +UVarIdent :: { FreeFoilTypecheck.SystemF.Parser.Abs.UVarIdent } +UVarIdent : L_UVarIdent { FreeFoilTypecheck.SystemF.Parser.Abs.UVarIdent $1 } + +Pattern :: { FreeFoilTypecheck.SystemF.Parser.Abs.Pattern } +Pattern + : Ident { FreeFoilTypecheck.SystemF.Parser.Abs.PatternVar $1 } + +Term3 :: { FreeFoilTypecheck.SystemF.Parser.Abs.Term } +Term3 + : Ident { FreeFoilTypecheck.SystemF.Parser.Abs.EVar $1 } + | 'true' { FreeFoilTypecheck.SystemF.Parser.Abs.ETrue } + | 'false' { FreeFoilTypecheck.SystemF.Parser.Abs.EFalse } + | Integer { FreeFoilTypecheck.SystemF.Parser.Abs.ENat $1 } + | UVarIdent { FreeFoilTypecheck.SystemF.Parser.Abs.TUVar $1 } + | 'Nat' { FreeFoilTypecheck.SystemF.Parser.Abs.TNat } + | 'Bool' { FreeFoilTypecheck.SystemF.Parser.Abs.TBool } + | 'Type' { FreeFoilTypecheck.SystemF.Parser.Abs.TType } + | '(' Term ')' { $2 } + +Term2 :: { FreeFoilTypecheck.SystemF.Parser.Abs.Term } +Term2 + : Term2 '+' Term3 { FreeFoilTypecheck.SystemF.Parser.Abs.EAdd $1 $3 } + | Term2 '-' Term3 { FreeFoilTypecheck.SystemF.Parser.Abs.ESub $1 $3 } + | 'iszero' '(' Term ')' { FreeFoilTypecheck.SystemF.Parser.Abs.EIsZero $3 } + | Term3 '->' Term2 { FreeFoilTypecheck.SystemF.Parser.Abs.TArrow $1 $3 } + | Term3 { $1 } + +Term1 :: { FreeFoilTypecheck.SystemF.Parser.Abs.Term } +Term1 + : 'if' Term1 'then' Term1 'else' Term1 { FreeFoilTypecheck.SystemF.Parser.Abs.EIf $2 $4 $6 } + | 'let' Pattern '=' Term1 'in' ScopedTerm { FreeFoilTypecheck.SystemF.Parser.Abs.ELet $2 $4 $6 } + | 'λ' Pattern ':' Term '.' ScopedTerm { FreeFoilTypecheck.SystemF.Parser.Abs.EAbsTyped $2 $4 $6 } + | 'λ' Pattern '.' ScopedTerm { FreeFoilTypecheck.SystemF.Parser.Abs.EAbsUntyped $2 $4 } + | Term1 Term2 { FreeFoilTypecheck.SystemF.Parser.Abs.EApp $1 $2 } + | 'Λ' Pattern '.' ScopedTerm { FreeFoilTypecheck.SystemF.Parser.Abs.ETAbs $2 $4 } + | Term1 '[' Term ']' { FreeFoilTypecheck.SystemF.Parser.Abs.ETApp $1 $3 } + | 'for' Pattern 'in' '[' Term1 '..' Term1 ']' 'do' ScopedTerm { FreeFoilTypecheck.SystemF.Parser.Abs.EFor $2 $5 $7 $10 } + | 'forall' Pattern '.' ScopedTerm { FreeFoilTypecheck.SystemF.Parser.Abs.TForAll $2 $4 } + | Term2 { $1 } + +Term :: { FreeFoilTypecheck.SystemF.Parser.Abs.Term } +Term + : Term1 ':' Term { FreeFoilTypecheck.SystemF.Parser.Abs.ETyped $1 $3 } + | Term1 { $1 } + +ScopedTerm :: { FreeFoilTypecheck.SystemF.Parser.Abs.ScopedTerm } +ScopedTerm + : Term1 { FreeFoilTypecheck.SystemF.Parser.Abs.ScopedTerm $1 } + +{ + +type Err = Either String + +happyError :: [Token] -> Err a +happyError ts = Left $ + "syntax error at " ++ tokenPos ts ++ + case ts of + [] -> [] + [Err _] -> " due to lexer error" + t:_ -> " before `" ++ (prToken t) ++ "'" + +myLexer :: String -> [Token] +myLexer = tokens + +} + diff --git a/src/FreeFoilTypecheck/SystemF/Parser/Print.hs b/src/FreeFoilTypecheck/SystemF/Parser/Print.hs new file mode 100644 index 0000000..69becab --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Parser/Print.hs @@ -0,0 +1,175 @@ +-- File generated by the BNF Converter (bnfc 2.9.5). + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +#if __GLASGOW_HASKELL__ <= 708 +{-# LANGUAGE OverlappingInstances #-} +#endif + +-- | Pretty-printer for FreeFoilTypecheck. + +module FreeFoilTypecheck.SystemF.Parser.Print where + +import Prelude + ( ($), (.) + , Bool(..), (==), (<) + , Int, Integer, Double, (+), (-), (*) + , String, (++) + , ShowS, showChar, showString + , all, elem, foldr, id, map, null, replicate, shows, span + ) +import Data.Char ( Char, isSpace ) +import qualified FreeFoilTypecheck.SystemF.Parser.Abs + +-- | The top-level printing method. + +printTree :: Print a => a -> String +printTree = render . prt 0 + +type Doc = [ShowS] -> [ShowS] + +doc :: ShowS -> Doc +doc = (:) + +render :: Doc -> String +render d = rend 0 False (map ($ "") $ d []) "" + where + rend + :: Int -- ^ Indentation level. + -> Bool -- ^ Pending indentation to be output before next character? + -> [String] + -> ShowS + rend i p = \case + "[" :ts -> char '[' . rend i False ts + "(" :ts -> char '(' . rend i False ts + "{" :ts -> onNewLine i p . showChar '{' . new (i+1) ts + "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts + "}" :ts -> onNewLine (i-1) p . showChar '}' . new (i-1) ts + [";"] -> char ';' + ";" :ts -> char ';' . new i ts + t : ts@(s:_) | closingOrPunctuation s + -> pending . showString t . rend i False ts + t :ts -> pending . space t . rend i False ts + [] -> id + where + -- Output character after pending indentation. + char :: Char -> ShowS + char c = pending . showChar c + + -- Output pending indentation. + pending :: ShowS + pending = if p then indent i else id + + -- Indentation (spaces) for given indentation level. + indent :: Int -> ShowS + indent i = replicateS (2*i) (showChar ' ') + + -- Continue rendering in new line with new indentation. + new :: Int -> [String] -> ShowS + new j ts = showChar '\n' . rend j True ts + + -- Make sure we are on a fresh line. + onNewLine :: Int -> Bool -> ShowS + onNewLine i p = (if p then id else showChar '\n') . indent i + + -- Separate given string from following text by a space (if needed). + space :: String -> ShowS + space t s = + case (all isSpace t, null spc, null rest) of + (True , _ , True ) -> [] -- remove trailing space + (False, _ , True ) -> t -- remove trailing space + (False, True, False) -> t ++ ' ' : s -- add space if none + _ -> t ++ s + where + (spc, rest) = span isSpace s + + closingOrPunctuation :: String -> Bool + closingOrPunctuation [c] = c `elem` closerOrPunct + closingOrPunctuation _ = False + + closerOrPunct :: String + closerOrPunct = ")],;" + +parenth :: Doc -> Doc +parenth ss = doc (showChar '(') . ss . doc (showChar ')') + +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +concatD :: [Doc] -> Doc +concatD = foldr (.) id + +replicateS :: Int -> ShowS -> ShowS +replicateS n f = concatS (replicate n f) + +-- | The printer class does the job. + +class Print a where + prt :: Int -> a -> Doc + +instance {-# OVERLAPPABLE #-} Print a => Print [a] where + prt i = concatD . map (prt i) + +instance Print Char where + prt _ c = doc (showChar '\'' . mkEsc '\'' c . showChar '\'') + +instance Print String where + prt _ = printString + +printString :: String -> Doc +printString s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') + +mkEsc :: Char -> Char -> ShowS +mkEsc q = \case + s | s == q -> showChar '\\' . showChar s + '\\' -> showString "\\\\" + '\n' -> showString "\\n" + '\t' -> showString "\\t" + s -> showChar s + +prPrec :: Int -> Int -> Doc -> Doc +prPrec i j = if j < i then parenth else id + +instance Print Integer where + prt _ x = doc (shows x) + +instance Print Double where + prt _ x = doc (shows x) + +instance Print FreeFoilTypecheck.SystemF.Parser.Abs.Ident where + prt _ (FreeFoilTypecheck.SystemF.Parser.Abs.Ident i) = doc $ showString i +instance Print FreeFoilTypecheck.SystemF.Parser.Abs.UVarIdent where + prt _ (FreeFoilTypecheck.SystemF.Parser.Abs.UVarIdent i) = doc $ showString i +instance Print FreeFoilTypecheck.SystemF.Parser.Abs.Pattern where + prt i = \case + FreeFoilTypecheck.SystemF.Parser.Abs.PatternVar id_ -> prPrec i 0 (concatD [prt 0 id_]) + +instance Print FreeFoilTypecheck.SystemF.Parser.Abs.Term where + prt i = \case + FreeFoilTypecheck.SystemF.Parser.Abs.EVar id_ -> prPrec i 3 (concatD [prt 0 id_]) + FreeFoilTypecheck.SystemF.Parser.Abs.ETrue -> prPrec i 3 (concatD [doc (showString "true")]) + FreeFoilTypecheck.SystemF.Parser.Abs.EFalse -> prPrec i 3 (concatD [doc (showString "false")]) + FreeFoilTypecheck.SystemF.Parser.Abs.ENat n -> prPrec i 3 (concatD [prt 0 n]) + FreeFoilTypecheck.SystemF.Parser.Abs.EAdd term1 term2 -> prPrec i 2 (concatD [prt 2 term1, doc (showString "+"), prt 3 term2]) + FreeFoilTypecheck.SystemF.Parser.Abs.ESub term1 term2 -> prPrec i 2 (concatD [prt 2 term1, doc (showString "-"), prt 3 term2]) + FreeFoilTypecheck.SystemF.Parser.Abs.EIf term1 term2 term3 -> prPrec i 1 (concatD [doc (showString "if"), prt 1 term1, doc (showString "then"), prt 1 term2, doc (showString "else"), prt 1 term3]) + FreeFoilTypecheck.SystemF.Parser.Abs.EIsZero term -> prPrec i 2 (concatD [doc (showString "iszero"), doc (showString "("), prt 0 term, doc (showString ")")]) + FreeFoilTypecheck.SystemF.Parser.Abs.ETyped term1 term2 -> prPrec i 0 (concatD [prt 1 term1, doc (showString ":"), prt 0 term2]) + FreeFoilTypecheck.SystemF.Parser.Abs.ELet pattern_ term scopedterm -> prPrec i 1 (concatD [doc (showString "let"), prt 0 pattern_, doc (showString "="), prt 1 term, doc (showString "in"), prt 0 scopedterm]) + FreeFoilTypecheck.SystemF.Parser.Abs.EAbsTyped pattern_ term scopedterm -> prPrec i 1 (concatD [doc (showString "\955"), prt 0 pattern_, doc (showString ":"), prt 0 term, doc (showString "."), prt 0 scopedterm]) + FreeFoilTypecheck.SystemF.Parser.Abs.EAbsUntyped pattern_ scopedterm -> prPrec i 1 (concatD [doc (showString "\955"), prt 0 pattern_, doc (showString "."), prt 0 scopedterm]) + FreeFoilTypecheck.SystemF.Parser.Abs.EApp term1 term2 -> prPrec i 1 (concatD [prt 1 term1, prt 2 term2]) + FreeFoilTypecheck.SystemF.Parser.Abs.ETAbs pattern_ scopedterm -> prPrec i 1 (concatD [doc (showString "\923"), prt 0 pattern_, doc (showString "."), prt 0 scopedterm]) + FreeFoilTypecheck.SystemF.Parser.Abs.ETApp term1 term2 -> prPrec i 1 (concatD [prt 1 term1, doc (showString "["), prt 0 term2, doc (showString "]")]) + FreeFoilTypecheck.SystemF.Parser.Abs.EFor pattern_ term1 term2 scopedterm -> prPrec i 1 (concatD [doc (showString "for"), prt 0 pattern_, doc (showString "in"), doc (showString "["), prt 1 term1, doc (showString ".."), prt 1 term2, doc (showString "]"), doc (showString "do"), prt 0 scopedterm]) + FreeFoilTypecheck.SystemF.Parser.Abs.TUVar uvarident -> prPrec i 3 (concatD [prt 0 uvarident]) + FreeFoilTypecheck.SystemF.Parser.Abs.TNat -> prPrec i 3 (concatD [doc (showString "Nat")]) + FreeFoilTypecheck.SystemF.Parser.Abs.TBool -> prPrec i 3 (concatD [doc (showString "Bool")]) + FreeFoilTypecheck.SystemF.Parser.Abs.TType -> prPrec i 3 (concatD [doc (showString "Type")]) + FreeFoilTypecheck.SystemF.Parser.Abs.TArrow term1 term2 -> prPrec i 2 (concatD [prt 3 term1, doc (showString "->"), prt 2 term2]) + FreeFoilTypecheck.SystemF.Parser.Abs.TForAll pattern_ scopedterm -> prPrec i 1 (concatD [doc (showString "forall"), prt 0 pattern_, doc (showString "."), prt 0 scopedterm]) + +instance Print FreeFoilTypecheck.SystemF.Parser.Abs.ScopedTerm where + prt i = \case + FreeFoilTypecheck.SystemF.Parser.Abs.ScopedTerm term -> prPrec i 0 (concatD [prt 1 term]) diff --git a/src/FreeFoilTypecheck/SystemF/Parser/Skel.hs b/src/FreeFoilTypecheck/SystemF/Parser/Skel.hs new file mode 100644 index 0000000..5f9ce55 --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Parser/Skel.hs @@ -0,0 +1,57 @@ +-- File generated by the BNF Converter (bnfc 2.9.5). + +-- Templates for pattern matching on abstract syntax + +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +module FreeFoilTypecheck.SystemF.Parser.Skel where + +import Prelude (($), Either(..), String, (++), Show, show) +import qualified FreeFoilTypecheck.SystemF.Parser.Abs + +type Err = Either String +type Result = Err String + +failure :: Show a => a -> Result +failure x = Left $ "Undefined case: " ++ show x + +transIdent :: FreeFoilTypecheck.SystemF.Parser.Abs.Ident -> Result +transIdent x = case x of + FreeFoilTypecheck.SystemF.Parser.Abs.Ident string -> failure x + +transUVarIdent :: FreeFoilTypecheck.SystemF.Parser.Abs.UVarIdent -> Result +transUVarIdent x = case x of + FreeFoilTypecheck.SystemF.Parser.Abs.UVarIdent string -> failure x + +transPattern :: FreeFoilTypecheck.SystemF.Parser.Abs.Pattern -> Result +transPattern x = case x of + FreeFoilTypecheck.SystemF.Parser.Abs.PatternVar ident -> failure x + +transTerm :: FreeFoilTypecheck.SystemF.Parser.Abs.Term -> Result +transTerm x = case x of + FreeFoilTypecheck.SystemF.Parser.Abs.EVar ident -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.ETrue -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.EFalse -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.ENat integer -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.EAdd term1 term2 -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.ESub term1 term2 -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.EIf term1 term2 term3 -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.EIsZero term -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.ETyped term1 term2 -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.ELet pattern_ term scopedterm -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.EAbsTyped pattern_ term scopedterm -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.EAbsUntyped pattern_ scopedterm -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.EApp term1 term2 -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.ETAbs pattern_ scopedterm -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.ETApp term1 term2 -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.EFor pattern_ term1 term2 scopedterm -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.TUVar uvarident -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.TNat -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.TBool -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.TType -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.TArrow term1 term2 -> failure x + FreeFoilTypecheck.SystemF.Parser.Abs.TForAll pattern_ scopedterm -> failure x + +transScopedTerm :: FreeFoilTypecheck.SystemF.Parser.Abs.ScopedTerm -> Result +transScopedTerm x = case x of + FreeFoilTypecheck.SystemF.Parser.Abs.ScopedTerm term -> failure x diff --git a/src/HM/Parser/Test.hs b/src/FreeFoilTypecheck/SystemF/Parser/Test.hs similarity index 86% rename from src/HM/Parser/Test.hs rename to src/FreeFoilTypecheck/SystemF/Parser/Test.hs index 8924b5e..b79d711 100644 --- a/src/HM/Parser/Test.hs +++ b/src/FreeFoilTypecheck/SystemF/Parser/Test.hs @@ -18,11 +18,11 @@ import System.Environment ( getArgs ) import System.Exit ( exitFailure ) import Control.Monad ( when ) -import HM.Parser.Abs () -import HM.Parser.Lex ( Token, mkPosToken ) -import HM.Parser.Par ( pPattern, myLexer ) -import HM.Parser.Print ( Print, printTree ) -import HM.Parser.Skel () +import FreeFoilTypecheck.SystemF.Parser.Abs () +import FreeFoilTypecheck.SystemF.Parser.Lex ( Token, mkPosToken ) +import FreeFoilTypecheck.SystemF.Parser.Par ( pPattern, myLexer ) +import FreeFoilTypecheck.SystemF.Parser.Print ( Print, printTree ) +import FreeFoilTypecheck.SystemF.Parser.Skel () type Err = Either String type ParseFun a = [Token] -> Err a diff --git a/src/FreeFoilTypecheck/SystemF/Syntax.hs b/src/FreeFoilTypecheck/SystemF/Syntax.hs new file mode 100644 index 0000000..e6c7c98 --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Syntax.hs @@ -0,0 +1,13 @@ +module FreeFoilTypecheck.SystemF.Syntax + ( + -- module FreeFoilTypecheck.SystemF.Syntax.Exp, + -- module FreeFoilTypecheck.SystemF.Syntax.Type, + module FreeFoilTypecheck.SystemF.Syntax.Pattern, + module FreeFoilTypecheck.SystemF.Syntax.Term, + ) +where + +-- import FreeFoilTypecheck.SystemF.Syntax.Exp hiding (EAbs, ETAbs, getPatternBinder) +import FreeFoilTypecheck.SystemF.Syntax.Pattern +import FreeFoilTypecheck.SystemF.Syntax.Term hiding (getPatternBinder) +-- import FreeFoilTypecheck.SystemF.Syntax.Type hiding (getPatternBinder) diff --git a/src/FreeFoilTypecheck/SystemF/Syntax/Pattern.hs b/src/FreeFoilTypecheck/SystemF/Syntax/Pattern.hs new file mode 100644 index 0000000..bf6d296 --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Syntax/Pattern.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module FreeFoilTypecheck.SystemF.Syntax.Pattern where + + +import qualified FreeFoilTypecheck.SystemF.Parser.Abs as Raw +import Control.Monad.Foil.TH +import Control.Monad.Free.Foil.TH + + +-- ** Scope-safe patterns + +mkFoilPattern ''Raw.Ident ''Raw.Pattern +deriveCoSinkable ''Raw.Ident ''Raw.Pattern +mkToFoilPattern ''Raw.Ident ''Raw.Pattern +mkFromFoilPattern ''Raw.Ident ''Raw.Pattern +deriveUnifiablePattern ''Raw.Ident ''Raw.Pattern + +mkGetPatternBinder ''Raw.Ident ''Raw.Pattern diff --git a/src/FreeFoilTypecheck/SystemF/Syntax/Term.hs b/src/FreeFoilTypecheck/SystemF/Syntax/Term.hs new file mode 100644 index 0000000..f31618c --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Syntax/Term.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} + +module FreeFoilTypecheck.SystemF.Syntax.Term where + +import qualified Control.Monad.Foil as Foil +import Control.Monad.Free.Foil +import Control.Monad.Free.Foil.TH +import Data.Bifunctor.TH +import Data.Map (Map) +import qualified Data.Map as Map +import Data.String (IsString (..)) +import qualified FreeFoilTypecheck.SystemF.Parser.Abs as Raw +import qualified FreeFoilTypecheck.SystemF.Parser.Par as Raw +import qualified FreeFoilTypecheck.SystemF.Parser.Print as Raw +import FreeFoilTypecheck.SystemF.Syntax.Pattern hiding (getPatternBinder) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> :set -XDataKinds +-- >>> import qualified Control.Monad.Foil as Foil +-- >>> import Control.Monad.Free.Foil +-- >>> import Data.String (fromString) + +-- * Generated code (terms) + +-- ** Signature + +mkSignature ''Raw.Term ''Raw.Ident ''Raw.ScopedTerm ''Raw.Pattern +deriveZipMatch ''TermSig +deriveBifunctor ''TermSig +deriveBifoldable ''TermSig +deriveBitraversable ''TermSig + +-- ** Pattern synonyms + +mkPatternSynonyms ''TermSig +{-# COMPLETE Var, ETrue, EFalse, ENat, EAdd, ESub, EIf, EIsZero, ETyped, ELet, EAbsTyped, EAbsUntyped, EApp, ETApp, ETAbs, EFor, TUVar, TNat, TBool, TArrow, TForAll #-} + +-- ** Conversion helpers + +mkConvertToFreeFoil ''Raw.Term ''Raw.Ident ''Raw.ScopedTerm ''Raw.Pattern +mkConvertFromFreeFoil ''Raw.Term ''Raw.Ident ''Raw.ScopedTerm ''Raw.Pattern + +-- * User-defined code + +type Term n = AST FoilPattern TermSig n +type Term' = Term Foil.VoidS + +-- ** Conversion helpers (terms) + +-- | Convert 'Raw.Term' into a scope-safe term. +-- This is a special case of 'convertToAST'. +toTerm :: (Foil.Distinct n) => Foil.Scope n -> Map Raw.Ident (Foil.Name n) -> Raw.Term -> AST FoilPattern TermSig n +toTerm = convertToAST convertToTermSig toFoilPattern getTermFromScopedTerm + +-- | Convert 'Raw.Term' into a closed scope-safe term. +-- This is a special case of 'toTerm'. +toTermClosed :: Raw.Term -> Term Foil.VoidS +toTermClosed = toTerm Foil.emptyScope Map.empty + +-- | Convert a scope-safe representation back into 'Raw.Term'. +-- This is a special case of 'convertFromAST'. +-- +-- 'Raw.VarIdent' names are generated based on the raw identifiers in the underlying foil representation. +-- +-- This function does not recover location information for variables, patterns, or scoped terms. +fromTerm :: Term n -> Raw.Term +fromTerm = + convertFromAST + convertFromTermSig + -- (\_ -> error "location missing") + (Raw.EVar) + (fromFoilPattern mkVarIdent) + Raw.ScopedTerm + mkVarIdent + where + mkVarIdent n = Raw.Ident ("x" ++ show n) + + +-- | Parse scope-safe terms via raw representation. +-- +-- >>> fromString "let x = 2 + 2 in let y = x - 1 in let x = 3 in y + x + y" :: Term Foil.VoidS +-- let x0 = 2 + 2 in let x1 = x0 - 1 in let x2 = 3 in x1 + x2 + x1 +instance IsString (Term Foil.VoidS) where + fromString input = case Raw.pTerm (Raw.myLexer input) of + Left err -> error ("could not parse term: " <> input <> "\n " <> err) + Right term -> toTermClosed term + +-- | Pretty-print scope-safe terms via"λ" Ident ":" Type "." Term1 raw representation. +instance Show (Term n) where + show = Raw.printTree . fromTerm + +-- | Determine if given Term is a type or not +-- isType :: Term n -> Bool +-- isType (TUVar _) = True +-- isType (TNat) = True +-- isType (TType) = True +-- isType (TBool) = True +-- isType (TArrow _ _) = True +-- isType (TForAll _ _) = True +-- isType _ = False diff --git a/src/FreeFoilTypecheck/SystemF/Typecheck.hs b/src/FreeFoilTypecheck/SystemF/Typecheck.hs new file mode 100644 index 0000000..90fdfb6 --- /dev/null +++ b/src/FreeFoilTypecheck/SystemF/Typecheck.hs @@ -0,0 +1,210 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} + +module FreeFoilTypecheck.SystemF.Typecheck where + +import qualified Control.Monad.Foil as Foil +import qualified Control.Monad.Foil.Internal as Foil +import qualified Control.Monad.Free.Foil as FreeFoil +import Data.Bifoldable (Bifoldable (bifoldMap)) +import qualified Data.IntMap as IntMap +import Data.Maybe (mapMaybe) +import qualified FreeFoilTypecheck.SystemF.Parser.Print as Raw +import FreeFoilTypecheck.SystemF.Syntax +import Unsafe.Coerce (unsafeCoerce) + +-- $setup +-- >>> :set -XOverloadedStrings + +-- | Typechecks an expression and maybe returns an error. +-- >>> typecheckClosed "2 - (1 + 1)" "Nat" +-- Right Nat +-- >>> typecheckClosed "2 - (1 + true)" "Nat" +-- Left "expected type\n Nat\nbut got type\n Bool\nwhen typechecking expession\n true\n" +-- >>> typecheckClosed "2 - (1 + 1)" "Bool" +-- Left "expected type\n Bool\nbut got type\n Nat\nwhen typechecking expession\n 2 - (1 + 1)\n" +-- >>> typecheckClosed "let x = 1 in let y = 2 in x + (let x = 3 in x + y)" "Nat" +-- Right Nat +typecheckClosed + :: Term Foil.VoidS {- exp -} + -> Term Foil.VoidS {- type -} + -> Either String (Term Foil.VoidS) {- type -} +typecheckClosed = typecheck Foil.emptyNameMap + +type Context n = Foil.NameMap n (Term n) + +extendContext :: Foil.Distinct n => Foil.NameBinder n l -> Term n -> Context n -> Context l +extendContext binder type_ = + case (Foil.assertExt binder, Foil.assertDistinct binder) of + (Foil.Ext, Foil.Distinct) -> + fmap Foil.sink . Foil.addNameBinder binder type_ + +typecheck + :: Foil.Distinct n + => Context n + -> Term n {- exp -} + -> Term n {- type -} + -> Either String (Term n) {- type -} +-- typecheck scope (EAbsUntyped binder body) (TArrow argType _resultType) = +typecheck scope (EIf eCond eThen eElse) expectedType = do + _ <- typecheck scope eCond TBool + _ <- typecheck scope eThen expectedType + typecheck scope eElse expectedType +typecheck scope (ELet e1 (FoilPatternVar binder) e2) expectedType = do + case Foil.assertDistinct binder of + Foil.Distinct -> do + type1 <- inferType scope e1 + let newScope = extendContext binder type1 scope + case (Foil.assertDistinct binder, Foil.assertExt binder) of + (Foil.Distinct, Foil.Ext) -> do + type2 <- typecheck newScope e2 (Foil.sink expectedType) -- FIXME + unsinkType scope type2 +typecheck scope (EAbsUntyped pat body) expectedType = do + case expectedType of + TArrow argType _resultType -> + typecheck scope (EAbsTyped argType pat body) expectedType + _ -> error ("unexpected λ-abstraction when typechecking against functional type: " <> show expectedType) +typecheck scope e expectedType = do + typeOfE <- inferType scope e + if FreeFoil.alphaEquiv (nameMapToScope scope) typeOfE expectedType + then return typeOfE + else + Left $ + unlines + [ "expected type", + " " ++ show expectedType, + "but got type", + " " ++ Raw.printTree (fromTerm typeOfE), + "when typechecking expession", + " " ++ show e + ] + +inferType + :: (Foil.Distinct n) + => Context n + -> Term n + -> Either String (Term n) +inferType scope (FreeFoil.Var n) = -- Γ, x : T ⊢ x : T + case (Foil.lookupName n scope) of + TType -> Right (FreeFoil.Var n) + t -> Right t +inferType _scope ETrue = return TBool +inferType _scope EFalse = return TBool +inferType _scope (ENat _) = return TNat +inferType scope (EAdd l r) = do + _ <- typecheck scope l TNat + _ <- typecheck scope r TNat + return TNat +inferType scope (ESub l r) = do + _ <- typecheck scope l TNat + _ <- typecheck scope r TNat + return TNat +inferType scope (EIf eCond eThen eElse) = do + _ <- typecheck scope eCond TBool + typeOfThen <- inferType scope eThen + _ <- typecheck scope eElse typeOfThen + return typeOfThen +inferType scope (EIsZero e) = do + _ <- typecheck scope e TNat + return TBool +inferType scope (ETyped expr type_) = do + typecheck scope expr type_ +inferType scope (ELet e1 (FoilPatternVar binder) e2) = do + case Foil.assertDistinct binder of + Foil.Distinct -> do + -- Γ ⊢ let x = e1 in e2 : ? + type1 <- inferType scope e1 -- Γ ⊢ e1 : type1 + let newScope = extendContext binder type1 scope -- Γ' = Γ, x : type1 + type' <- inferType newScope e2 -- Γ' ⊢ e2 : ? + unsinkType scope type' +inferType scope (EAbsTyped type_ (FoilPatternVar x) e) = do + case Foil.assertDistinct x of + Foil.Distinct -> do + -- Γ ⊢ λx : type_. e : ? + let newScope = extendContext x type_ scope -- Γ' = Γ, x : type_ + type' <- inferType newScope e + fmap (TArrow type_) (unsinkType scope type') +inferType _scope (EAbsUntyped _ _) = error "cannot infer λ-abstraction without explicit type annotation for the argument" -- TODO +inferType scope (EApp e1 e2) = do + -- (Γ ⊢ e1) (Γ ⊢ e2) : ? + type1 <- inferType scope e1 -- Γ ⊢ e1 : type1 + case type1 of + TArrow type_ types -> do + _ <- typecheck scope e2 type_ + return types + _ -> Left ("expected type\n TArrow\nbut got type\n " <> show type1) +inferType scope (EFor e1 e2 (FoilPatternVar x) expr) = do + case Foil.assertDistinct x of + Foil.Distinct -> do + _ <- typecheck scope e1 TNat + _ <- typecheck scope e2 TNat + let newScope = extendContext x TNat scope + type' <- inferType newScope expr + unsinkType scope type' +inferType scope (ETAbs pat@(FoilPatternVar x) e) = do + case Foil.assertDistinct x of + Foil.Distinct -> do + let newScope = extendContext x TType scope + type' <- inferType newScope e + fmap (TForAll pat) (unsinkType newScope type') +inferType scope (ETApp e t) = do + eType <- inferType scope e + case eType of + TForAll (FoilPatternVar binder) tbody -> do + let subst = Foil.addSubst Foil.identitySubst binder t + in return (FreeFoil.substitute (nameMapToScope scope) subst tbody) + _ -> Left ("unexpected type application (not a forall)") +inferType _ (TNat) = Right TNat +inferType _ (TType) = Right TType +inferType _ (TBool) = Right TBool +inferType _ (TArrow l r) = Right (TArrow l r) +inferType _ (TForAll p b) = Right (TForAll p b) +inferType _ (TUVar n) = Right (TUVar n) + +unsinkType :: Foil.Distinct l => Context n -> Term l -> Either String (Term n) +unsinkType scope type_ = do + case unsinkAST (nameMapToScope scope) type_ of + Nothing -> Left "dependent types!" + Just type'' -> return type'' + +-- HELPERS + +-- FIXME: should be in free-foil +deriving instance Functor (Foil.NameMap n) +deriving instance Foldable (Foil.NameMap n) +deriving instance Traversable (Foil.NameMap n) + +nameMapToScope :: Foil.NameMap n a -> Foil.Scope n +nameMapToScope (Foil.NameMap m) = Foil.UnsafeScope (IntMap.keysSet m) + + +-- TForAll :: Pattern n l -> Term l -> Term n +-- +-- let z = 1 in ΛX. λy:X. z +-- +-- Γ, z : Nat ⊢ ∀X. X → Nat +-- Γ ⊢ ∀X. X → Nat +-- +-- Γ, z : Nat, X ⊢ X → Nat +-- Γ, X ⊢ X → Nat +-- +-- FIXME: should be part of free-foil +unsinkAST :: (Foil.Distinct l, Foil.CoSinkable binder, Bifoldable sig) => Foil.Scope n -> FreeFoil.AST binder sig l -> Maybe (FreeFoil.AST binder sig n) +unsinkAST scope term + | all (`Foil.member` scope) (freeVarsOf term) = Just (unsafeCoerce term) + | otherwise = Nothing + +freeVarsOf :: (Foil.Distinct n, Foil.CoSinkable binder, Bifoldable sig) => FreeFoil.AST binder sig n -> [Foil.Name n] +freeVarsOf = \case + FreeFoil.Var name -> [name] + FreeFoil.Node node -> bifoldMap freeVarsOfScopedAST freeVarsOf node + +-- ΛY. λy:Y. let z = y in ΛX. λa : X. z +-- Γ, Y, y : Y, z : Y ⊢ ∀X. X → Y +freeVarsOfScopedAST :: (Foil.Distinct n, Foil.CoSinkable binder, Bifoldable sig) => FreeFoil.ScopedAST binder sig n -> [Foil.Name n] +freeVarsOfScopedAST (FreeFoil.ScopedAST binder body) = + case Foil.assertDistinct binder of + Foil.Distinct -> mapMaybe (Foil.unsinkNamePattern binder) (freeVarsOf body) diff --git a/src/HM/Parser/Par.hs b/src/HM/Parser/Par.hs deleted file mode 100644 index 9268b3c..0000000 --- a/src/HM/Parser/Par.hs +++ /dev/null @@ -1,1350 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} -{-# LANGUAGE PatternSynonyms #-} - -module HM.Parser.Par - ( happyError - , myLexer - , pPattern - , pExp3 - , pExp2 - , pExp1 - , pExp - , pScopedExp - , pType - ) where - -import Prelude - -import qualified HM.Parser.Abs -import HM.Parser.Lex -import qualified Data.Array as Happy_Data_Array -import qualified Data.Bits as Bits -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.20.1.1 - -data HappyAbsSyn - = HappyTerminal (Token) - | HappyErrorToken Prelude.Int - | HappyAbsSyn10 (HM.Parser.Abs.Ident) - | HappyAbsSyn11 (Integer) - | HappyAbsSyn12 (HM.Parser.Abs.Pattern) - | HappyAbsSyn13 (HM.Parser.Abs.Exp) - | HappyAbsSyn17 (HM.Parser.Abs.ScopedExp) - | HappyAbsSyn18 (HM.Parser.Abs.Type) - -{- to allow type-synonyms as our monads (likely - - with explicitly-specified bind and return) - - in Haskell98, it seems that with - - /type M a = .../, then /(HappyReduction M)/ - - is not allowed. But Happy is a - - code-generator that can just substitute it. -type HappyReduction m = - Prelude.Int - -> (Token) - -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> m HappyAbsSyn --} - -action_0, - action_1, - action_2, - action_3, - action_4, - action_5, - action_6, - action_7, - action_8, - action_9, - action_10, - action_11, - action_12, - action_13, - action_14, - action_15, - action_16, - action_17, - action_18, - action_19, - action_20, - action_21, - action_22, - action_23, - action_24, - action_25, - action_26, - action_27, - action_28, - action_29, - action_30, - action_31, - action_32, - action_33, - action_34, - action_35, - action_36, - action_37, - action_38, - action_39, - action_40, - action_41, - action_42, - action_43, - action_44, - action_45, - action_46, - action_47, - action_48, - action_49, - action_50, - action_51, - action_52, - action_53, - action_54, - action_55, - action_56, - action_57, - action_58, - action_59, - action_60, - action_61, - action_62, - action_63, - action_64, - action_65, - action_66, - action_67, - action_68, - action_69, - action_70, - action_71 :: () => Prelude.Int -> ({-HappyReduction (Err) = -} - Prelude.Int - -> (Token) - -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> (Err) HappyAbsSyn) - -happyReduce_7, - happyReduce_8, - happyReduce_9, - happyReduce_10, - happyReduce_11, - happyReduce_12, - happyReduce_13, - happyReduce_14, - happyReduce_15, - happyReduce_16, - happyReduce_17, - happyReduce_18, - happyReduce_19, - happyReduce_20, - happyReduce_21, - happyReduce_22, - happyReduce_23, - happyReduce_24, - happyReduce_25, - happyReduce_26, - happyReduce_27, - happyReduce_28, - happyReduce_29, - happyReduce_30 :: () => ({-HappyReduction (Err) = -} - Prelude.Int - -> (Token) - -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> (Err) HappyAbsSyn) - -happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int -happyExpList = Happy_Data_Array.listArray (0,235) ([0,0,1024,32768,16384,416,4096,34816,52,512,46848,7,64,63200,0,8,7900,0,1536,0,0,0,32,0,0,0,2048,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,384,0,0,0,0,0,0,0,4096,47104,61,0,0,0,0,16384,0,8,7900,0,1,0,0,0,32,0,0,0,0,32768,0,0,0,0,258,1681,0,0,0,2048,17408,26,3072,0,0,0,0,0,0,0,0,0,0,4096,2048,52,512,33024,6,768,0,0,12288,0,0,128,0,0,32,0,1024,28160,15,128,46144,1,0,64,0,4,0,0,384,0,0,0,0,0,0,0,0,1,0,4,3950,0,1,0,4096,47104,61,0,12,0,1024,0,0,0,0,0,0,0,0,6,0,1024,12800,13,0,0,0,16,13452,0,2,1975,16384,8208,210,2048,56320,30,256,56192,3,32,31600,0,0,0,0,0,0,0,0,0,512,46848,7,64,53796,0,0,1,0,32769,987,0,0,0,0 - ]) - -{-# NOINLINE happyExpListPerState #-} -happyExpListPerState st = - token_strs_expected - where token_strs = ["error","%dummy","%start_pPattern","%start_pExp3","%start_pExp2","%start_pExp1","%start_pExp","%start_pScopedExp","%start_pType","Ident","Integer","Pattern","Exp3","Exp2","Exp1","Exp","ScopedExp","Type","'('","')'","'+'","'-'","'->'","'.'","'..'","':'","'='","'Bool'","'Nat'","'['","']'","'do'","'else'","'false'","'for'","'if'","'in'","'iszero'","'let'","'then'","'true'","'\955'","L_Ident","L_integ","%eof"] - bit_start = st Prelude.* 45 - bit_end = (st Prelude.+ 1) Prelude.* 45 - read_bit = readArrayBit happyExpList - bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] - bits_indexed = Prelude.zip bits [0..44] - token_strs_expected = Prelude.concatMap f bits_indexed - f (Prelude.False, _) = [] - f (Prelude.True, nr) = [token_strs Prelude.!! nr] - -action_0 (43) = happyShift action_8 -action_0 (10) = happyGoto action_32 -action_0 (12) = happyGoto action_33 -action_0 _ = happyFail (happyExpListPerState 0) - -action_1 (19) = happyShift action_18 -action_1 (34) = happyShift action_19 -action_1 (41) = happyShift action_24 -action_1 (43) = happyShift action_8 -action_1 (44) = happyShift action_26 -action_1 (10) = happyGoto action_12 -action_1 (11) = happyGoto action_13 -action_1 (13) = happyGoto action_31 -action_1 _ = happyFail (happyExpListPerState 1) - -action_2 (19) = happyShift action_18 -action_2 (34) = happyShift action_19 -action_2 (38) = happyShift action_22 -action_2 (41) = happyShift action_24 -action_2 (43) = happyShift action_8 -action_2 (44) = happyShift action_26 -action_2 (10) = happyGoto action_12 -action_2 (11) = happyGoto action_13 -action_2 (13) = happyGoto action_14 -action_2 (14) = happyGoto action_30 -action_2 _ = happyFail (happyExpListPerState 2) - -action_3 (19) = happyShift action_18 -action_3 (34) = happyShift action_19 -action_3 (35) = happyShift action_20 -action_3 (36) = happyShift action_21 -action_3 (38) = happyShift action_22 -action_3 (39) = happyShift action_23 -action_3 (41) = happyShift action_24 -action_3 (42) = happyShift action_25 -action_3 (43) = happyShift action_8 -action_3 (44) = happyShift action_26 -action_3 (10) = happyGoto action_12 -action_3 (11) = happyGoto action_13 -action_3 (13) = happyGoto action_14 -action_3 (14) = happyGoto action_15 -action_3 (15) = happyGoto action_29 -action_3 _ = happyFail (happyExpListPerState 3) - -action_4 (19) = happyShift action_18 -action_4 (34) = happyShift action_19 -action_4 (35) = happyShift action_20 -action_4 (36) = happyShift action_21 -action_4 (38) = happyShift action_22 -action_4 (39) = happyShift action_23 -action_4 (41) = happyShift action_24 -action_4 (42) = happyShift action_25 -action_4 (43) = happyShift action_8 -action_4 (44) = happyShift action_26 -action_4 (10) = happyGoto action_12 -action_4 (11) = happyGoto action_13 -action_4 (13) = happyGoto action_14 -action_4 (14) = happyGoto action_15 -action_4 (15) = happyGoto action_27 -action_4 (16) = happyGoto action_28 -action_4 _ = happyFail (happyExpListPerState 4) - -action_5 (19) = happyShift action_18 -action_5 (34) = happyShift action_19 -action_5 (35) = happyShift action_20 -action_5 (36) = happyShift action_21 -action_5 (38) = happyShift action_22 -action_5 (39) = happyShift action_23 -action_5 (41) = happyShift action_24 -action_5 (42) = happyShift action_25 -action_5 (43) = happyShift action_8 -action_5 (44) = happyShift action_26 -action_5 (10) = happyGoto action_12 -action_5 (11) = happyGoto action_13 -action_5 (13) = happyGoto action_14 -action_5 (14) = happyGoto action_15 -action_5 (15) = happyGoto action_16 -action_5 (17) = happyGoto action_17 -action_5 _ = happyFail (happyExpListPerState 5) - -action_6 (28) = happyShift action_10 -action_6 (29) = happyShift action_11 -action_6 (18) = happyGoto action_9 -action_6 _ = happyFail (happyExpListPerState 6) - -action_7 (43) = happyShift action_8 -action_7 _ = happyFail (happyExpListPerState 7) - -action_8 _ = happyReduce_7 - -action_9 (23) = happyShift action_44 -action_9 (45) = happyAccept -action_9 _ = happyFail (happyExpListPerState 9) - -action_10 _ = happyReduce_29 - -action_11 _ = happyReduce_28 - -action_12 _ = happyReduce_10 - -action_13 _ = happyReduce_13 - -action_14 _ = happyReduce_18 - -action_15 (21) = happyShift action_34 -action_15 (22) = happyShift action_35 -action_15 _ = happyReduce_24 - -action_16 (19) = happyShift action_18 -action_16 (34) = happyShift action_19 -action_16 (38) = happyShift action_22 -action_16 (41) = happyShift action_24 -action_16 (43) = happyShift action_8 -action_16 (44) = happyShift action_26 -action_16 (10) = happyGoto action_12 -action_16 (11) = happyGoto action_13 -action_16 (13) = happyGoto action_14 -action_16 (14) = happyGoto action_36 -action_16 _ = happyReduce_27 - -action_17 (45) = happyAccept -action_17 _ = happyFail (happyExpListPerState 17) - -action_18 (19) = happyShift action_18 -action_18 (34) = happyShift action_19 -action_18 (35) = happyShift action_20 -action_18 (36) = happyShift action_21 -action_18 (38) = happyShift action_22 -action_18 (39) = happyShift action_23 -action_18 (41) = happyShift action_24 -action_18 (42) = happyShift action_25 -action_18 (43) = happyShift action_8 -action_18 (44) = happyShift action_26 -action_18 (10) = happyGoto action_12 -action_18 (11) = happyGoto action_13 -action_18 (13) = happyGoto action_14 -action_18 (14) = happyGoto action_15 -action_18 (15) = happyGoto action_27 -action_18 (16) = happyGoto action_43 -action_18 _ = happyFail (happyExpListPerState 18) - -action_19 _ = happyReduce_12 - -action_20 (43) = happyShift action_8 -action_20 (10) = happyGoto action_32 -action_20 (12) = happyGoto action_42 -action_20 _ = happyFail (happyExpListPerState 20) - -action_21 (19) = happyShift action_18 -action_21 (34) = happyShift action_19 -action_21 (35) = happyShift action_20 -action_21 (36) = happyShift action_21 -action_21 (38) = happyShift action_22 -action_21 (39) = happyShift action_23 -action_21 (41) = happyShift action_24 -action_21 (42) = happyShift action_25 -action_21 (43) = happyShift action_8 -action_21 (44) = happyShift action_26 -action_21 (10) = happyGoto action_12 -action_21 (11) = happyGoto action_13 -action_21 (13) = happyGoto action_14 -action_21 (14) = happyGoto action_15 -action_21 (15) = happyGoto action_41 -action_21 _ = happyFail (happyExpListPerState 21) - -action_22 (19) = happyShift action_40 -action_22 _ = happyFail (happyExpListPerState 22) - -action_23 (43) = happyShift action_8 -action_23 (10) = happyGoto action_32 -action_23 (12) = happyGoto action_39 -action_23 _ = happyFail (happyExpListPerState 23) - -action_24 _ = happyReduce_11 - -action_25 (43) = happyShift action_8 -action_25 (10) = happyGoto action_32 -action_25 (12) = happyGoto action_38 -action_25 _ = happyFail (happyExpListPerState 25) - -action_26 _ = happyReduce_8 - -action_27 (19) = happyShift action_18 -action_27 (26) = happyShift action_37 -action_27 (34) = happyShift action_19 -action_27 (38) = happyShift action_22 -action_27 (41) = happyShift action_24 -action_27 (43) = happyShift action_8 -action_27 (44) = happyShift action_26 -action_27 (10) = happyGoto action_12 -action_27 (11) = happyGoto action_13 -action_27 (13) = happyGoto action_14 -action_27 (14) = happyGoto action_36 -action_27 _ = happyReduce_26 - -action_28 (45) = happyAccept -action_28 _ = happyFail (happyExpListPerState 28) - -action_29 (19) = happyShift action_18 -action_29 (34) = happyShift action_19 -action_29 (38) = happyShift action_22 -action_29 (41) = happyShift action_24 -action_29 (43) = happyShift action_8 -action_29 (44) = happyShift action_26 -action_29 (45) = happyAccept -action_29 (10) = happyGoto action_12 -action_29 (11) = happyGoto action_13 -action_29 (13) = happyGoto action_14 -action_29 (14) = happyGoto action_36 -action_29 _ = happyFail (happyExpListPerState 29) - -action_30 (21) = happyShift action_34 -action_30 (22) = happyShift action_35 -action_30 (45) = happyAccept -action_30 _ = happyFail (happyExpListPerState 30) - -action_31 (45) = happyAccept -action_31 _ = happyFail (happyExpListPerState 31) - -action_32 _ = happyReduce_9 - -action_33 (45) = happyAccept -action_33 _ = happyFail (happyExpListPerState 33) - -action_34 (19) = happyShift action_18 -action_34 (34) = happyShift action_19 -action_34 (41) = happyShift action_24 -action_34 (43) = happyShift action_8 -action_34 (44) = happyShift action_26 -action_34 (10) = happyGoto action_12 -action_34 (11) = happyGoto action_13 -action_34 (13) = happyGoto action_54 -action_34 _ = happyFail (happyExpListPerState 34) - -action_35 (19) = happyShift action_18 -action_35 (34) = happyShift action_19 -action_35 (41) = happyShift action_24 -action_35 (43) = happyShift action_8 -action_35 (44) = happyShift action_26 -action_35 (10) = happyGoto action_12 -action_35 (11) = happyGoto action_13 -action_35 (13) = happyGoto action_53 -action_35 _ = happyFail (happyExpListPerState 35) - -action_36 (21) = happyShift action_34 -action_36 (22) = happyShift action_35 -action_36 _ = happyReduce_22 - -action_37 (28) = happyShift action_10 -action_37 (29) = happyShift action_11 -action_37 (18) = happyGoto action_52 -action_37 _ = happyFail (happyExpListPerState 37) - -action_38 (26) = happyShift action_51 -action_38 _ = happyFail (happyExpListPerState 38) - -action_39 (27) = happyShift action_50 -action_39 _ = happyFail (happyExpListPerState 39) - -action_40 (19) = happyShift action_18 -action_40 (34) = happyShift action_19 -action_40 (35) = happyShift action_20 -action_40 (36) = happyShift action_21 -action_40 (38) = happyShift action_22 -action_40 (39) = happyShift action_23 -action_40 (41) = happyShift action_24 -action_40 (42) = happyShift action_25 -action_40 (43) = happyShift action_8 -action_40 (44) = happyShift action_26 -action_40 (10) = happyGoto action_12 -action_40 (11) = happyGoto action_13 -action_40 (13) = happyGoto action_14 -action_40 (14) = happyGoto action_15 -action_40 (15) = happyGoto action_27 -action_40 (16) = happyGoto action_49 -action_40 _ = happyFail (happyExpListPerState 40) - -action_41 (19) = happyShift action_18 -action_41 (34) = happyShift action_19 -action_41 (38) = happyShift action_22 -action_41 (40) = happyShift action_48 -action_41 (41) = happyShift action_24 -action_41 (43) = happyShift action_8 -action_41 (44) = happyShift action_26 -action_41 (10) = happyGoto action_12 -action_41 (11) = happyGoto action_13 -action_41 (13) = happyGoto action_14 -action_41 (14) = happyGoto action_36 -action_41 _ = happyFail (happyExpListPerState 41) - -action_42 (37) = happyShift action_47 -action_42 _ = happyFail (happyExpListPerState 42) - -action_43 (20) = happyShift action_46 -action_43 _ = happyFail (happyExpListPerState 43) - -action_44 (28) = happyShift action_10 -action_44 (29) = happyShift action_11 -action_44 (18) = happyGoto action_45 -action_44 _ = happyFail (happyExpListPerState 44) - -action_45 (23) = happyShift action_44 -action_45 _ = happyReduce_30 - -action_46 _ = happyReduce_14 - -action_47 (30) = happyShift action_59 -action_47 _ = happyFail (happyExpListPerState 47) - -action_48 (19) = happyShift action_18 -action_48 (34) = happyShift action_19 -action_48 (35) = happyShift action_20 -action_48 (36) = happyShift action_21 -action_48 (38) = happyShift action_22 -action_48 (39) = happyShift action_23 -action_48 (41) = happyShift action_24 -action_48 (42) = happyShift action_25 -action_48 (43) = happyShift action_8 -action_48 (44) = happyShift action_26 -action_48 (10) = happyGoto action_12 -action_48 (11) = happyGoto action_13 -action_48 (13) = happyGoto action_14 -action_48 (14) = happyGoto action_15 -action_48 (15) = happyGoto action_58 -action_48 _ = happyFail (happyExpListPerState 48) - -action_49 (20) = happyShift action_57 -action_49 _ = happyFail (happyExpListPerState 49) - -action_50 (19) = happyShift action_18 -action_50 (34) = happyShift action_19 -action_50 (35) = happyShift action_20 -action_50 (36) = happyShift action_21 -action_50 (38) = happyShift action_22 -action_50 (39) = happyShift action_23 -action_50 (41) = happyShift action_24 -action_50 (42) = happyShift action_25 -action_50 (43) = happyShift action_8 -action_50 (44) = happyShift action_26 -action_50 (10) = happyGoto action_12 -action_50 (11) = happyGoto action_13 -action_50 (13) = happyGoto action_14 -action_50 (14) = happyGoto action_15 -action_50 (15) = happyGoto action_56 -action_50 _ = happyFail (happyExpListPerState 50) - -action_51 (28) = happyShift action_10 -action_51 (29) = happyShift action_11 -action_51 (18) = happyGoto action_55 -action_51 _ = happyFail (happyExpListPerState 51) - -action_52 (23) = happyShift action_44 -action_52 _ = happyReduce_25 - -action_53 _ = happyReduce_16 - -action_54 _ = happyReduce_15 - -action_55 (23) = happyShift action_44 -action_55 (24) = happyShift action_63 -action_55 _ = happyFail (happyExpListPerState 55) - -action_56 (19) = happyShift action_18 -action_56 (34) = happyShift action_19 -action_56 (37) = happyShift action_62 -action_56 (38) = happyShift action_22 -action_56 (41) = happyShift action_24 -action_56 (43) = happyShift action_8 -action_56 (44) = happyShift action_26 -action_56 (10) = happyGoto action_12 -action_56 (11) = happyGoto action_13 -action_56 (13) = happyGoto action_14 -action_56 (14) = happyGoto action_36 -action_56 _ = happyFail (happyExpListPerState 56) - -action_57 _ = happyReduce_17 - -action_58 (19) = happyShift action_18 -action_58 (33) = happyShift action_61 -action_58 (34) = happyShift action_19 -action_58 (38) = happyShift action_22 -action_58 (41) = happyShift action_24 -action_58 (43) = happyShift action_8 -action_58 (44) = happyShift action_26 -action_58 (10) = happyGoto action_12 -action_58 (11) = happyGoto action_13 -action_58 (13) = happyGoto action_14 -action_58 (14) = happyGoto action_36 -action_58 _ = happyFail (happyExpListPerState 58) - -action_59 (19) = happyShift action_18 -action_59 (34) = happyShift action_19 -action_59 (35) = happyShift action_20 -action_59 (36) = happyShift action_21 -action_59 (38) = happyShift action_22 -action_59 (39) = happyShift action_23 -action_59 (41) = happyShift action_24 -action_59 (42) = happyShift action_25 -action_59 (43) = happyShift action_8 -action_59 (44) = happyShift action_26 -action_59 (10) = happyGoto action_12 -action_59 (11) = happyGoto action_13 -action_59 (13) = happyGoto action_14 -action_59 (14) = happyGoto action_15 -action_59 (15) = happyGoto action_60 -action_59 _ = happyFail (happyExpListPerState 59) - -action_60 (19) = happyShift action_18 -action_60 (25) = happyShift action_67 -action_60 (34) = happyShift action_19 -action_60 (38) = happyShift action_22 -action_60 (41) = happyShift action_24 -action_60 (43) = happyShift action_8 -action_60 (44) = happyShift action_26 -action_60 (10) = happyGoto action_12 -action_60 (11) = happyGoto action_13 -action_60 (13) = happyGoto action_14 -action_60 (14) = happyGoto action_36 -action_60 _ = happyFail (happyExpListPerState 60) - -action_61 (19) = happyShift action_18 -action_61 (34) = happyShift action_19 -action_61 (35) = happyShift action_20 -action_61 (36) = happyShift action_21 -action_61 (38) = happyShift action_22 -action_61 (39) = happyShift action_23 -action_61 (41) = happyShift action_24 -action_61 (42) = happyShift action_25 -action_61 (43) = happyShift action_8 -action_61 (44) = happyShift action_26 -action_61 (10) = happyGoto action_12 -action_61 (11) = happyGoto action_13 -action_61 (13) = happyGoto action_14 -action_61 (14) = happyGoto action_15 -action_61 (15) = happyGoto action_66 -action_61 _ = happyFail (happyExpListPerState 61) - -action_62 (19) = happyShift action_18 -action_62 (34) = happyShift action_19 -action_62 (35) = happyShift action_20 -action_62 (36) = happyShift action_21 -action_62 (38) = happyShift action_22 -action_62 (39) = happyShift action_23 -action_62 (41) = happyShift action_24 -action_62 (42) = happyShift action_25 -action_62 (43) = happyShift action_8 -action_62 (44) = happyShift action_26 -action_62 (10) = happyGoto action_12 -action_62 (11) = happyGoto action_13 -action_62 (13) = happyGoto action_14 -action_62 (14) = happyGoto action_15 -action_62 (15) = happyGoto action_16 -action_62 (17) = happyGoto action_65 -action_62 _ = happyFail (happyExpListPerState 62) - -action_63 (19) = happyShift action_18 -action_63 (34) = happyShift action_19 -action_63 (35) = happyShift action_20 -action_63 (36) = happyShift action_21 -action_63 (38) = happyShift action_22 -action_63 (39) = happyShift action_23 -action_63 (41) = happyShift action_24 -action_63 (42) = happyShift action_25 -action_63 (43) = happyShift action_8 -action_63 (44) = happyShift action_26 -action_63 (10) = happyGoto action_12 -action_63 (11) = happyGoto action_13 -action_63 (13) = happyGoto action_14 -action_63 (14) = happyGoto action_15 -action_63 (15) = happyGoto action_16 -action_63 (17) = happyGoto action_64 -action_63 _ = happyFail (happyExpListPerState 63) - -action_64 _ = happyReduce_21 - -action_65 _ = happyReduce_20 - -action_66 (19) = happyShift action_18 -action_66 (34) = happyShift action_19 -action_66 (38) = happyShift action_22 -action_66 (41) = happyShift action_24 -action_66 (43) = happyShift action_8 -action_66 (44) = happyShift action_26 -action_66 (10) = happyGoto action_12 -action_66 (11) = happyGoto action_13 -action_66 (13) = happyGoto action_14 -action_66 (14) = happyGoto action_36 -action_66 _ = happyReduce_19 - -action_67 (19) = happyShift action_18 -action_67 (34) = happyShift action_19 -action_67 (35) = happyShift action_20 -action_67 (36) = happyShift action_21 -action_67 (38) = happyShift action_22 -action_67 (39) = happyShift action_23 -action_67 (41) = happyShift action_24 -action_67 (42) = happyShift action_25 -action_67 (43) = happyShift action_8 -action_67 (44) = happyShift action_26 -action_67 (10) = happyGoto action_12 -action_67 (11) = happyGoto action_13 -action_67 (13) = happyGoto action_14 -action_67 (14) = happyGoto action_15 -action_67 (15) = happyGoto action_68 -action_67 _ = happyFail (happyExpListPerState 67) - -action_68 (19) = happyShift action_18 -action_68 (31) = happyShift action_69 -action_68 (34) = happyShift action_19 -action_68 (38) = happyShift action_22 -action_68 (41) = happyShift action_24 -action_68 (43) = happyShift action_8 -action_68 (44) = happyShift action_26 -action_68 (10) = happyGoto action_12 -action_68 (11) = happyGoto action_13 -action_68 (13) = happyGoto action_14 -action_68 (14) = happyGoto action_36 -action_68 _ = happyFail (happyExpListPerState 68) - -action_69 (32) = happyShift action_70 -action_69 _ = happyFail (happyExpListPerState 69) - -action_70 (19) = happyShift action_18 -action_70 (34) = happyShift action_19 -action_70 (35) = happyShift action_20 -action_70 (36) = happyShift action_21 -action_70 (38) = happyShift action_22 -action_70 (39) = happyShift action_23 -action_70 (41) = happyShift action_24 -action_70 (42) = happyShift action_25 -action_70 (43) = happyShift action_8 -action_70 (44) = happyShift action_26 -action_70 (10) = happyGoto action_12 -action_70 (11) = happyGoto action_13 -action_70 (13) = happyGoto action_14 -action_70 (14) = happyGoto action_15 -action_70 (15) = happyGoto action_16 -action_70 (17) = happyGoto action_71 -action_70 _ = happyFail (happyExpListPerState 70) - -action_71 _ = happyReduce_23 - -happyReduce_7 = happySpecReduce_1 10 happyReduction_7 -happyReduction_7 (HappyTerminal (PT _ (TV happy_var_1))) - = HappyAbsSyn10 - (HM.Parser.Abs.Ident happy_var_1 - ) -happyReduction_7 _ = notHappyAtAll - -happyReduce_8 = happySpecReduce_1 11 happyReduction_8 -happyReduction_8 (HappyTerminal (PT _ (TI happy_var_1))) - = HappyAbsSyn11 - ((read happy_var_1) :: Integer - ) -happyReduction_8 _ = notHappyAtAll - -happyReduce_9 = happySpecReduce_1 12 happyReduction_9 -happyReduction_9 (HappyAbsSyn10 happy_var_1) - = HappyAbsSyn12 - (HM.Parser.Abs.PatternVar happy_var_1 - ) -happyReduction_9 _ = notHappyAtAll - -happyReduce_10 = happySpecReduce_1 13 happyReduction_10 -happyReduction_10 (HappyAbsSyn10 happy_var_1) - = HappyAbsSyn13 - (HM.Parser.Abs.EVar happy_var_1 - ) -happyReduction_10 _ = notHappyAtAll - -happyReduce_11 = happySpecReduce_1 13 happyReduction_11 -happyReduction_11 _ - = HappyAbsSyn13 - (HM.Parser.Abs.ETrue - ) - -happyReduce_12 = happySpecReduce_1 13 happyReduction_12 -happyReduction_12 _ - = HappyAbsSyn13 - (HM.Parser.Abs.EFalse - ) - -happyReduce_13 = happySpecReduce_1 13 happyReduction_13 -happyReduction_13 (HappyAbsSyn11 happy_var_1) - = HappyAbsSyn13 - (HM.Parser.Abs.ENat happy_var_1 - ) -happyReduction_13 _ = notHappyAtAll - -happyReduce_14 = happySpecReduce_3 13 happyReduction_14 -happyReduction_14 _ - (HappyAbsSyn13 happy_var_2) - _ - = HappyAbsSyn13 - (happy_var_2 - ) -happyReduction_14 _ _ _ = notHappyAtAll - -happyReduce_15 = happySpecReduce_3 14 happyReduction_15 -happyReduction_15 (HappyAbsSyn13 happy_var_3) - _ - (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (HM.Parser.Abs.EAdd happy_var_1 happy_var_3 - ) -happyReduction_15 _ _ _ = notHappyAtAll - -happyReduce_16 = happySpecReduce_3 14 happyReduction_16 -happyReduction_16 (HappyAbsSyn13 happy_var_3) - _ - (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (HM.Parser.Abs.ESub happy_var_1 happy_var_3 - ) -happyReduction_16 _ _ _ = notHappyAtAll - -happyReduce_17 = happyReduce 4 14 happyReduction_17 -happyReduction_17 (_ `HappyStk` - (HappyAbsSyn13 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn13 - (HM.Parser.Abs.EIsZero happy_var_3 - ) `HappyStk` happyRest - -happyReduce_18 = happySpecReduce_1 14 happyReduction_18 -happyReduction_18 (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (happy_var_1 - ) -happyReduction_18 _ = notHappyAtAll - -happyReduce_19 = happyReduce 6 15 happyReduction_19 -happyReduction_19 ((HappyAbsSyn13 happy_var_6) `HappyStk` - _ `HappyStk` - (HappyAbsSyn13 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn13 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn13 - (HM.Parser.Abs.EIf happy_var_2 happy_var_4 happy_var_6 - ) `HappyStk` happyRest - -happyReduce_20 = happyReduce 6 15 happyReduction_20 -happyReduction_20 ((HappyAbsSyn17 happy_var_6) `HappyStk` - _ `HappyStk` - (HappyAbsSyn13 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn13 - (HM.Parser.Abs.ELet happy_var_2 happy_var_4 happy_var_6 - ) `HappyStk` happyRest - -happyReduce_21 = happyReduce 6 15 happyReduction_21 -happyReduction_21 ((HappyAbsSyn17 happy_var_6) `HappyStk` - _ `HappyStk` - (HappyAbsSyn18 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn13 - (HM.Parser.Abs.EAbs happy_var_2 happy_var_4 happy_var_6 - ) `HappyStk` happyRest - -happyReduce_22 = happySpecReduce_2 15 happyReduction_22 -happyReduction_22 (HappyAbsSyn13 happy_var_2) - (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (HM.Parser.Abs.EApp happy_var_1 happy_var_2 - ) -happyReduction_22 _ _ = notHappyAtAll - -happyReduce_23 = happyReduce 10 15 happyReduction_23 -happyReduction_23 ((HappyAbsSyn17 happy_var_10) `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyAbsSyn13 happy_var_7) `HappyStk` - _ `HappyStk` - (HappyAbsSyn13 happy_var_5) `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn13 - (HM.Parser.Abs.EFor happy_var_2 happy_var_5 happy_var_7 happy_var_10 - ) `HappyStk` happyRest - -happyReduce_24 = happySpecReduce_1 15 happyReduction_24 -happyReduction_24 (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (happy_var_1 - ) -happyReduction_24 _ = notHappyAtAll - -happyReduce_25 = happySpecReduce_3 16 happyReduction_25 -happyReduction_25 (HappyAbsSyn18 happy_var_3) - _ - (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (HM.Parser.Abs.ETyped happy_var_1 happy_var_3 - ) -happyReduction_25 _ _ _ = notHappyAtAll - -happyReduce_26 = happySpecReduce_1 16 happyReduction_26 -happyReduction_26 (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (happy_var_1 - ) -happyReduction_26 _ = notHappyAtAll - -happyReduce_27 = happySpecReduce_1 17 happyReduction_27 -happyReduction_27 (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn17 - (HM.Parser.Abs.ScopedExp happy_var_1 - ) -happyReduction_27 _ = notHappyAtAll - -happyReduce_28 = happySpecReduce_1 18 happyReduction_28 -happyReduction_28 _ - = HappyAbsSyn18 - (HM.Parser.Abs.TNat - ) - -happyReduce_29 = happySpecReduce_1 18 happyReduction_29 -happyReduction_29 _ - = HappyAbsSyn18 - (HM.Parser.Abs.TBool - ) - -happyReduce_30 = happySpecReduce_3 18 happyReduction_30 -happyReduction_30 (HappyAbsSyn18 happy_var_3) - _ - (HappyAbsSyn18 happy_var_1) - = HappyAbsSyn18 - (HM.Parser.Abs.TArrow happy_var_1 happy_var_3 - ) -happyReduction_30 _ _ _ = notHappyAtAll - -happyNewToken action sts stk [] = - action 45 45 notHappyAtAll (HappyState action) sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = action i i tk (HappyState action) sts stk tks in - case tk of { - PT _ (TS _ 1) -> cont 19; - PT _ (TS _ 2) -> cont 20; - PT _ (TS _ 3) -> cont 21; - PT _ (TS _ 4) -> cont 22; - PT _ (TS _ 5) -> cont 23; - PT _ (TS _ 6) -> cont 24; - PT _ (TS _ 7) -> cont 25; - PT _ (TS _ 8) -> cont 26; - PT _ (TS _ 9) -> cont 27; - PT _ (TS _ 10) -> cont 28; - PT _ (TS _ 11) -> cont 29; - PT _ (TS _ 12) -> cont 30; - PT _ (TS _ 13) -> cont 31; - PT _ (TS _ 14) -> cont 32; - PT _ (TS _ 15) -> cont 33; - PT _ (TS _ 16) -> cont 34; - PT _ (TS _ 17) -> cont 35; - PT _ (TS _ 18) -> cont 36; - PT _ (TS _ 19) -> cont 37; - PT _ (TS _ 20) -> cont 38; - PT _ (TS _ 21) -> cont 39; - PT _ (TS _ 22) -> cont 40; - PT _ (TS _ 23) -> cont 41; - PT _ (TS _ 24) -> cont 42; - PT _ (TV happy_dollar_dollar) -> cont 43; - PT _ (TI happy_dollar_dollar) -> cont 44; - _ -> happyError' ((tk:tks), []) - } - -happyError_ explist 45 tk tks = happyError' (tks, explist) -happyError_ explist _ tk tks = happyError' ((tk:tks), explist) - -happyThen :: () => Err a -> (a -> Err b) -> Err b -happyThen = ((>>=)) -happyReturn :: () => a -> Err a -happyReturn = (return) -happyThen1 m k tks = ((>>=)) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Err a -happyReturn1 = \a tks -> (return) a -happyError' :: () => ([(Token)], [Prelude.String]) -> Err a -happyError' = (\(tokens, _) -> happyError tokens) -pPattern tks = happySomeParser where - happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn12 z -> happyReturn z; _other -> notHappyAtAll }) - -pExp3 tks = happySomeParser where - happySomeParser = happyThen (happyParse action_1 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) - -pExp2 tks = happySomeParser where - happySomeParser = happyThen (happyParse action_2 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) - -pExp1 tks = happySomeParser where - happySomeParser = happyThen (happyParse action_3 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) - -pExp tks = happySomeParser where - happySomeParser = happyThen (happyParse action_4 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) - -pScopedExp tks = happySomeParser where - happySomeParser = happyThen (happyParse action_5 tks) (\x -> case x of {HappyAbsSyn17 z -> happyReturn z; _other -> notHappyAtAll }) - -pType tks = happySomeParser where - happySomeParser = happyThen (happyParse action_6 tks) (\x -> case x of {HappyAbsSyn18 z -> happyReturn z; _other -> notHappyAtAll }) - -happySeq = happyDontSeq - - -type Err = Either String - -happyError :: [Token] -> Err a -happyError ts = Left $ - "syntax error at " ++ tokenPos ts ++ - case ts of - [] -> [] - [Err _] -> " due to lexer error" - t:_ -> " before `" ++ (prToken t) ++ "'" - -myLexer :: String -> [Token] -myLexer = tokens -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -data Happy_IntList = HappyCons Prelude.Int Happy_IntList - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is ERROR_TOK, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -indexShortOffAddr arr off = arr Happy_Data_Array.! off - - -{-# INLINE happyLt #-} -happyLt x y = (x Prelude.< y) - - - - - - -readArrayBit arr bit = - Bits.testBit (indexShortOffAddr arr (bit `Prelude.div` 16)) (bit `Prelude.mod` 16) - - - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - - - -newtype HappyState b c = HappyState - (Prelude.Int -> -- token number - Prelude.Int -> -- token number (yes, again) - b -> -- token semantic value - HappyState b c -> -- current state - [HappyState b c] -> -- state stack - c) - - - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state (1) tk st sts stk@(x `HappyStk` _) = - let i = (case x of { HappyErrorToken (i) -> i }) in --- trace "shifting the error token" $ - new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk -happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk - = action nt j tk st ((st):(sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk -happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk -happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Prelude.- ((1) :: Prelude.Int)) sts of - sts1@(((st1@(HappyState (action))):(_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (action nt j tk st1 sts1 r) - -happyMonadReduce k nt fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k ((st):(sts)) of - sts1@(((st1@(HappyState (action))):(_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k ((st):(sts)) of - sts1@(((st1@(HappyState (action))):(_))) -> - let drop_stk = happyDropStk k stk - - - - - - _ = nt :: Prelude.Int - new_state = action - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop (0) l = l -happyDrop n ((_):(t)) = happyDrop (n Prelude.- ((1) :: Prelude.Int)) t - -happyDropStk (0) l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Prelude.- ((1)::Prelude.Int)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - - - - - - - - -happyGoto action j tk st = action j j tk (HappyState action) - - ------------------------------------------------------------------------------ --- Error recovery (ERROR_TOK is the error token) - --- parse error if we are in recovery and we fail again -happyFail explist (1) tk old_st _ stk@(x `HappyStk` _) = - let i = (case x of { HappyErrorToken (i) -> i }) in --- trace "failing" $ - happyError_ explist i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail explist i tk (HappyState (action)) sts stk = --- trace "entering error recovery" $ - action (1) (1) tk (HappyState (action)) sts ((HappyErrorToken (i)) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = Prelude.error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - - - - - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `Prelude.seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - - - - - - - - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. diff --git a/src/HM/Parser/Par.y b/src/HM/Parser/Par.y deleted file mode 100644 index b2caadd..0000000 --- a/src/HM/Parser/Par.y +++ /dev/null @@ -1,128 +0,0 @@ --- -*- haskell -*- File generated by the BNF Converter (bnfc 2.9.5). - --- Parser definition for use with Happy -{ -{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} -{-# LANGUAGE PatternSynonyms #-} - -module HM.Parser.Par - ( happyError - , myLexer - , pPattern - , pExp3 - , pExp2 - , pExp1 - , pExp - , pScopedExp - , pType - ) where - -import Prelude - -import qualified HM.Parser.Abs -import HM.Parser.Lex - -} - -%name pPattern Pattern -%name pExp3 Exp3 -%name pExp2 Exp2 -%name pExp1 Exp1 -%name pExp Exp -%name pScopedExp ScopedExp -%name pType Type --- no lexer declaration -%monad { Err } { (>>=) } { return } -%tokentype {Token} -%token - '(' { PT _ (TS _ 1) } - ')' { PT _ (TS _ 2) } - '+' { PT _ (TS _ 3) } - '-' { PT _ (TS _ 4) } - '->' { PT _ (TS _ 5) } - '.' { PT _ (TS _ 6) } - '..' { PT _ (TS _ 7) } - ':' { PT _ (TS _ 8) } - '=' { PT _ (TS _ 9) } - 'Bool' { PT _ (TS _ 10) } - 'Nat' { PT _ (TS _ 11) } - '[' { PT _ (TS _ 12) } - ']' { PT _ (TS _ 13) } - 'do' { PT _ (TS _ 14) } - 'else' { PT _ (TS _ 15) } - 'false' { PT _ (TS _ 16) } - 'for' { PT _ (TS _ 17) } - 'if' { PT _ (TS _ 18) } - 'in' { PT _ (TS _ 19) } - 'iszero' { PT _ (TS _ 20) } - 'let' { PT _ (TS _ 21) } - 'then' { PT _ (TS _ 22) } - 'true' { PT _ (TS _ 23) } - 'λ' { PT _ (TS _ 24) } - L_Ident { PT _ (TV $$) } - L_integ { PT _ (TI $$) } - -%% - -Ident :: { HM.Parser.Abs.Ident } -Ident : L_Ident { HM.Parser.Abs.Ident $1 } - -Integer :: { Integer } -Integer : L_integ { (read $1) :: Integer } - -Pattern :: { HM.Parser.Abs.Pattern } -Pattern : Ident { HM.Parser.Abs.PatternVar $1 } - -Exp3 :: { HM.Parser.Abs.Exp } -Exp3 - : Ident { HM.Parser.Abs.EVar $1 } - | 'true' { HM.Parser.Abs.ETrue } - | 'false' { HM.Parser.Abs.EFalse } - | Integer { HM.Parser.Abs.ENat $1 } - | '(' Exp ')' { $2 } - -Exp2 :: { HM.Parser.Abs.Exp } -Exp2 - : Exp2 '+' Exp3 { HM.Parser.Abs.EAdd $1 $3 } - | Exp2 '-' Exp3 { HM.Parser.Abs.ESub $1 $3 } - | 'iszero' '(' Exp ')' { HM.Parser.Abs.EIsZero $3 } - | Exp3 { $1 } - -Exp1 :: { HM.Parser.Abs.Exp } -Exp1 - : 'if' Exp1 'then' Exp1 'else' Exp1 { HM.Parser.Abs.EIf $2 $4 $6 } - | 'let' Pattern '=' Exp1 'in' ScopedExp { HM.Parser.Abs.ELet $2 $4 $6 } - | 'λ' Pattern ':' Type '.' ScopedExp { HM.Parser.Abs.EAbs $2 $4 $6 } - | Exp1 Exp2 { HM.Parser.Abs.EApp $1 $2 } - | 'for' Pattern 'in' '[' Exp1 '..' Exp1 ']' 'do' ScopedExp { HM.Parser.Abs.EFor $2 $5 $7 $10 } - | Exp2 { $1 } - -Exp :: { HM.Parser.Abs.Exp } -Exp : Exp1 ':' Type { HM.Parser.Abs.ETyped $1 $3 } | Exp1 { $1 } - -ScopedExp :: { HM.Parser.Abs.ScopedExp } -ScopedExp : Exp1 { HM.Parser.Abs.ScopedExp $1 } - -Type :: { HM.Parser.Abs.Type } -Type - : 'Nat' { HM.Parser.Abs.TNat } - | 'Bool' { HM.Parser.Abs.TBool } - | Type '->' Type { HM.Parser.Abs.TArrow $1 $3 } - -{ - -type Err = Either String - -happyError :: [Token] -> Err a -happyError ts = Left $ - "syntax error at " ++ tokenPos ts ++ - case ts of - [] -> [] - [Err _] -> " due to lexer error" - t:_ -> " before `" ++ (prToken t) ++ "'" - -myLexer :: String -> [Token] -myLexer = tokens - -} - diff --git a/src/HM/Parser/Print.hs b/src/HM/Parser/Print.hs deleted file mode 100644 index 6d81bb2..0000000 --- a/src/HM/Parser/Print.hs +++ /dev/null @@ -1,170 +0,0 @@ --- File generated by the BNF Converter (bnfc 2.9.5). - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -#if __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE OverlappingInstances #-} -#endif - --- | Pretty-printer for HM. - -module HM.Parser.Print where - -import Prelude - ( ($), (.) - , Bool(..), (==), (<) - , Int, Integer, Double, (+), (-), (*) - , String, (++) - , ShowS, showChar, showString - , all, elem, foldr, id, map, null, replicate, shows, span - ) -import Data.Char ( Char, isSpace ) -import qualified HM.Parser.Abs - --- | The top-level printing method. - -printTree :: Print a => a -> String -printTree = render . prt 0 - -type Doc = [ShowS] -> [ShowS] - -doc :: ShowS -> Doc -doc = (:) - -render :: Doc -> String -render d = rend 0 False (map ($ "") $ d []) "" - where - rend - :: Int -- ^ Indentation level. - -> Bool -- ^ Pending indentation to be output before next character? - -> [String] - -> ShowS - rend i p = \case - "[" :ts -> char '[' . rend i False ts - "(" :ts -> char '(' . rend i False ts - "{" :ts -> onNewLine i p . showChar '{' . new (i+1) ts - "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts - "}" :ts -> onNewLine (i-1) p . showChar '}' . new (i-1) ts - [";"] -> char ';' - ";" :ts -> char ';' . new i ts - t : ts@(s:_) | closingOrPunctuation s - -> pending . showString t . rend i False ts - t :ts -> pending . space t . rend i False ts - [] -> id - where - -- Output character after pending indentation. - char :: Char -> ShowS - char c = pending . showChar c - - -- Output pending indentation. - pending :: ShowS - pending = if p then indent i else id - - -- Indentation (spaces) for given indentation level. - indent :: Int -> ShowS - indent i = replicateS (2*i) (showChar ' ') - - -- Continue rendering in new line with new indentation. - new :: Int -> [String] -> ShowS - new j ts = showChar '\n' . rend j True ts - - -- Make sure we are on a fresh line. - onNewLine :: Int -> Bool -> ShowS - onNewLine i p = (if p then id else showChar '\n') . indent i - - -- Separate given string from following text by a space (if needed). - space :: String -> ShowS - space t s = - case (all isSpace t, null spc, null rest) of - (True , _ , True ) -> [] -- remove trailing space - (False, _ , True ) -> t -- remove trailing space - (False, True, False) -> t ++ ' ' : s -- add space if none - _ -> t ++ s - where - (spc, rest) = span isSpace s - - closingOrPunctuation :: String -> Bool - closingOrPunctuation [c] = c `elem` closerOrPunct - closingOrPunctuation _ = False - - closerOrPunct :: String - closerOrPunct = ")],;" - -parenth :: Doc -> Doc -parenth ss = doc (showChar '(') . ss . doc (showChar ')') - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -concatD :: [Doc] -> Doc -concatD = foldr (.) id - -replicateS :: Int -> ShowS -> ShowS -replicateS n f = concatS (replicate n f) - --- | The printer class does the job. - -class Print a where - prt :: Int -> a -> Doc - -instance {-# OVERLAPPABLE #-} Print a => Print [a] where - prt i = concatD . map (prt i) - -instance Print Char where - prt _ c = doc (showChar '\'' . mkEsc '\'' c . showChar '\'') - -instance Print String where - prt _ = printString - -printString :: String -> Doc -printString s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') - -mkEsc :: Char -> Char -> ShowS -mkEsc q = \case - s | s == q -> showChar '\\' . showChar s - '\\' -> showString "\\\\" - '\n' -> showString "\\n" - '\t' -> showString "\\t" - s -> showChar s - -prPrec :: Int -> Int -> Doc -> Doc -prPrec i j = if j < i then parenth else id - -instance Print Integer where - prt _ x = doc (shows x) - -instance Print Double where - prt _ x = doc (shows x) - -instance Print HM.Parser.Abs.Ident where - prt _ (HM.Parser.Abs.Ident i) = doc $ showString i -instance Print HM.Parser.Abs.Pattern where - prt i = \case - HM.Parser.Abs.PatternVar id_ -> prPrec i 0 (concatD [prt 0 id_]) - -instance Print HM.Parser.Abs.Exp where - prt i = \case - HM.Parser.Abs.EVar id_ -> prPrec i 3 (concatD [prt 0 id_]) - HM.Parser.Abs.ETrue -> prPrec i 3 (concatD [doc (showString "true")]) - HM.Parser.Abs.EFalse -> prPrec i 3 (concatD [doc (showString "false")]) - HM.Parser.Abs.ENat n -> prPrec i 3 (concatD [prt 0 n]) - HM.Parser.Abs.EAdd exp1 exp2 -> prPrec i 2 (concatD [prt 2 exp1, doc (showString "+"), prt 3 exp2]) - HM.Parser.Abs.ESub exp1 exp2 -> prPrec i 2 (concatD [prt 2 exp1, doc (showString "-"), prt 3 exp2]) - HM.Parser.Abs.EIf exp1 exp2 exp3 -> prPrec i 1 (concatD [doc (showString "if"), prt 1 exp1, doc (showString "then"), prt 1 exp2, doc (showString "else"), prt 1 exp3]) - HM.Parser.Abs.EIsZero exp -> prPrec i 2 (concatD [doc (showString "iszero"), doc (showString "("), prt 0 exp, doc (showString ")")]) - HM.Parser.Abs.ETyped exp type_ -> prPrec i 0 (concatD [prt 1 exp, doc (showString ":"), prt 0 type_]) - HM.Parser.Abs.ELet pattern_ exp scopedexp -> prPrec i 1 (concatD [doc (showString "let"), prt 0 pattern_, doc (showString "="), prt 1 exp, doc (showString "in"), prt 0 scopedexp]) - HM.Parser.Abs.EAbs pattern_ type_ scopedexp -> prPrec i 1 (concatD [doc (showString "\955"), prt 0 pattern_, doc (showString ":"), prt 0 type_, doc (showString "."), prt 0 scopedexp]) - HM.Parser.Abs.EApp exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, prt 2 exp2]) - HM.Parser.Abs.EFor pattern_ exp1 exp2 scopedexp -> prPrec i 1 (concatD [doc (showString "for"), prt 0 pattern_, doc (showString "in"), doc (showString "["), prt 1 exp1, doc (showString ".."), prt 1 exp2, doc (showString "]"), doc (showString "do"), prt 0 scopedexp]) - -instance Print HM.Parser.Abs.ScopedExp where - prt i = \case - HM.Parser.Abs.ScopedExp exp -> prPrec i 0 (concatD [prt 1 exp]) - -instance Print HM.Parser.Abs.Type where - prt i = \case - HM.Parser.Abs.TNat -> prPrec i 0 (concatD [doc (showString "Nat")]) - HM.Parser.Abs.TBool -> prPrec i 0 (concatD [doc (showString "Bool")]) - HM.Parser.Abs.TArrow type_1 type_2 -> prPrec i 0 (concatD [prt 0 type_1, doc (showString "->"), prt 0 type_2]) diff --git a/src/HM/Parser/Skel.hs b/src/HM/Parser/Skel.hs deleted file mode 100644 index 25f6f29..0000000 --- a/src/HM/Parser/Skel.hs +++ /dev/null @@ -1,50 +0,0 @@ --- File generated by the BNF Converter (bnfc 2.9.5). - --- Templates for pattern matching on abstract syntax - -{-# OPTIONS_GHC -fno-warn-unused-matches #-} - -module HM.Parser.Skel where - -import Prelude (($), Either(..), String, (++), Show, show) -import qualified HM.Parser.Abs - -type Err = Either String -type Result = Err String - -failure :: Show a => a -> Result -failure x = Left $ "Undefined case: " ++ show x - -transIdent :: HM.Parser.Abs.Ident -> Result -transIdent x = case x of - HM.Parser.Abs.Ident string -> failure x - -transPattern :: HM.Parser.Abs.Pattern -> Result -transPattern x = case x of - HM.Parser.Abs.PatternVar ident -> failure x - -transExp :: HM.Parser.Abs.Exp -> Result -transExp x = case x of - HM.Parser.Abs.EVar ident -> failure x - HM.Parser.Abs.ETrue -> failure x - HM.Parser.Abs.EFalse -> failure x - HM.Parser.Abs.ENat integer -> failure x - HM.Parser.Abs.EAdd exp1 exp2 -> failure x - HM.Parser.Abs.ESub exp1 exp2 -> failure x - HM.Parser.Abs.EIf exp1 exp2 exp3 -> failure x - HM.Parser.Abs.EIsZero exp -> failure x - HM.Parser.Abs.ETyped exp type_ -> failure x - HM.Parser.Abs.ELet pattern_ exp scopedexp -> failure x - HM.Parser.Abs.EAbs pattern_ type_ scopedexp -> failure x - HM.Parser.Abs.EApp exp1 exp2 -> failure x - HM.Parser.Abs.EFor pattern_ exp1 exp2 scopedexp -> failure x - -transScopedExp :: HM.Parser.Abs.ScopedExp -> Result -transScopedExp x = case x of - HM.Parser.Abs.ScopedExp exp -> failure x - -transType :: HM.Parser.Abs.Type -> Result -transType x = case x of - HM.Parser.Abs.TNat -> failure x - HM.Parser.Abs.TBool -> failure x - HM.Parser.Abs.TArrow type_1 type_2 -> failure x diff --git a/src/HM/Syntax.hs b/src/HM/Syntax.hs deleted file mode 100644 index 63ca7d9..0000000 --- a/src/HM/Syntax.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} - -module HM.Syntax where - -import qualified Control.Monad.Foil as Foil -import Control.Monad.Free.Foil -import Control.Monad.Free.Foil.TH -import Data.Bifunctor.TH -import Data.Map (Map) -import qualified Data.Map as Map -import Data.String (IsString (..)) -import qualified HM.Parser.Abs as Raw -import qualified HM.Parser.Par as Raw -import qualified HM.Parser.Print as Raw - --- $setup --- >>> :set -XOverloadedStrings --- >>> :set -XDataKinds --- >>> import qualified Control.Monad.Foil as Foil --- >>> import Control.Monad.Free.Foil --- >>> import Data.String (fromString) - --- * Generated code - --- ** Signature - -mkSignature ''Raw.Exp ''Raw.Ident ''Raw.ScopedExp ''Raw.Pattern -deriveZipMatch ''ExpSig -deriveBifunctor ''ExpSig -deriveBifoldable ''ExpSig -deriveBitraversable ''ExpSig - --- ** Pattern synonyms - -mkPatternSynonyms ''ExpSig - -{-# COMPLETE Var, ETrue, EFalse, ENat, EAdd, ESub, EIf, EIsZero, ETyped, ELet, EAbs, EApp, EFor #-} - --- ** Conversion helpers - -mkConvertToFreeFoil ''Raw.Exp ''Raw.Ident ''Raw.ScopedExp ''Raw.Pattern -mkConvertFromFreeFoil ''Raw.Exp ''Raw.Ident ''Raw.ScopedExp ''Raw.Pattern - --- * User-defined code - -type Exp n = AST ExpSig n - --- ** Conversion helpers - --- | Convert 'Raw.Exp' into a scope-safe expression. --- This is a special case of 'convertToAST'. -toExp :: (Foil.Distinct n) => Foil.Scope n -> Map Raw.Ident (Foil.Name n) -> Raw.Exp -> AST ExpSig n -toExp = convertToAST convertToExpSig getPatternBinder getExpFromScopedExp - --- | Convert 'Raw.Exp' into a closed scope-safe expression. --- This is a special case of 'toExp'. -toExpClosed :: Raw.Exp -> Exp Foil.VoidS -toExpClosed = toExp Foil.emptyScope Map.empty - --- | Convert a scope-safe representation back into 'Raw.Exp'. --- This is a special case of 'convertFromAST'. --- --- 'Raw.VarIdent' names are generated based on the raw identifiers in the underlying foil representation. --- --- This function does not recover location information for variables, patterns, or scoped terms. -fromExp :: Exp n -> Raw.Exp -fromExp = - convertFromAST - convertFromExpSig - Raw.EVar - Raw.PatternVar - Raw.ScopedExp - (\n -> Raw.Ident ("x" ++ show n)) - --- | Parse scope-safe terms via raw representation. --- --- >>> fromString "let x = 2 + 2 in let y = x - 1 in let x = 3 in y + x + y" :: Exp Foil.VoidS --- let x0 = 2 + 2 in let x1 = x0 - 1 in let x2 = 3 in x1 + x2 + x1 -instance IsString (Exp Foil.VoidS) where - fromString input = case Raw.pExp (Raw.myLexer input) of - Left err -> error ("could not parse expression: " <> input <> "\n " <> err) - Right term -> toExpClosed term - --- | Pretty-print scope-safe terms via"λ" Ident ":" Type "." Exp1 raw representation. -instance Show (Exp n) where - show = Raw.printTree . fromExp diff --git a/src/HM/Typecheck.hs b/src/HM/Typecheck.hs deleted file mode 100644 index 1f89e69..0000000 --- a/src/HM/Typecheck.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module HM.Typecheck where - -import Control.Monad.Foil - ( NameMap, - addNameBinder, - emptyNameMap, - lookupName, - ) -import qualified Control.Monad.Foil as Foil -import qualified Control.Monad.Free.Foil as FreeFoil -import HM.Parser.Abs (Type (..)) -import qualified HM.Parser.Print as Raw -import HM.Syntax - --- $setup --- >>> :set -XOverloadedStrings --- >>> import HM.Parser.Abs (Type (..)) - --- | Typechecks an expression and maybe returns an error. --- >>> typecheckClosed "2 - (1 + 1)" TNat --- Right TNat --- >>> typecheckClosed "2 - (1 + true)" TNat --- Left "expected type\n TNat\nbut got type\n Bool\nwhen typechecking expession\n true\n" --- >>> typecheckClosed "2 - (1 + 1)" TBool --- Left "expected type\n TBool\nbut got type\n Nat\nwhen typechecking expession\n 2 - (1 + 1)\n" --- >>> typecheckClosed "let x = 1 in let y = 2 in x + (let x = 3 in x + y)" TNat --- Right TNat -typecheckClosed :: Exp Foil.VoidS -> Type -> Either String Type -typecheckClosed = typecheck emptyNameMap - -typecheck :: NameMap n Type -> Exp n -> Type -> Either String Type -typecheck scope e expectedType = do - typeOfE <- inferType scope e - if typeOfE == expectedType - then return typeOfE - else - Left $ - unlines - [ "expected type", - " " ++ show expectedType, - "but got type", - " " ++ Raw.printTree typeOfE, - "when typechecking expession", - " " ++ show e - ] - -inferType :: NameMap n Type -> Exp n -> Either String Type -inferType scope (FreeFoil.Var n) = Right (lookupName n scope) -- Γ, x : T ⊢ x : T -inferType _scope ETrue = return TBool -inferType _scope EFalse = return TBool -inferType _scope (ENat _) = return TNat -inferType scope (EAdd l r) = do - _ <- typecheck scope l TNat - _ <- typecheck scope r TNat - return TNat -inferType scope (ESub l r) = do - _ <- typecheck scope l TNat - _ <- typecheck scope r TNat - return TNat -inferType scope (EIf eCond eThen eElse) = do - _ <- typecheck scope eCond TBool - typeOfThen <- inferType scope eThen - _ <- typecheck scope eElse typeOfThen - return typeOfThen -inferType scope (EIsZero e) = do - _ <- typecheck scope e TNat - return TBool -inferType scope (ETyped expr type_) = do - typecheck scope expr type_ -inferType scope (ELet e1 x e2) = do - -- Γ ⊢ let x = e1 in e2 : ? - type1 <- inferType scope e1 -- Γ ⊢ e1 : type1 - let newScope = addNameBinder x type1 scope -- Γ' = Γ, x : type1 - inferType newScope e2 -- Γ' ⊢ e2 : ? -inferType scope (EAbs type_ x e) = do - -- Γ ⊢ λx : type_. e : ? - let newScope = addNameBinder x type_ scope -- Γ' = Γ, x : type_ - TArrow type_ <$> inferType newScope e -inferType scope (EApp e1 e2) = do - -- (Γ ⊢ e1) (Γ ⊢ e2) : ? - type1 <- inferType scope e1 -- Γ ⊢ e1 : type1 - case type1 of - TArrow type_ types -> do - _ <- typecheck scope e2 type_ - return types - _ -> Left ("expected type\n TArrow\nbut got type\n " <> show type1) -inferType scope (EFor e1 e2 x expr) = do - _ <- typecheck scope e1 TNat - _ <- typecheck scope e2 TNat - let newScope = addNameBinder x TNat scope - inferType newScope expr diff --git a/stack.yaml b/stack.yaml index 6d193a9..68546c0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,4 +2,4 @@ resolver: nightly-2024-08-02 packages: - . extra-deps: - - free-foil-0.0.3@sha256:cc4440d3d6ad4234611120fdecb228b621e0cabf57c1e8b8fb35282aa6fe0cfb,3134 + - free-foil-0.2.0@sha256:7f99c518a63ff314c7c8ca9776625e22ef56c5170593b52c82fea6f461ac753b,3300 diff --git a/stack.yaml.lock b/stack.yaml.lock index c5245b5..5d5a225 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,12 +5,12 @@ packages: - completed: - hackage: free-foil-0.0.3@sha256:cc4440d3d6ad4234611120fdecb228b621e0cabf57c1e8b8fb35282aa6fe0cfb,3134 + hackage: free-foil-0.2.0@sha256:7f99c518a63ff314c7c8ca9776625e22ef56c5170593b52c82fea6f461ac753b,3300 pantry-tree: - sha256: 9996c023bf037b2006e7e84abdba963dad3ade30aaf20ec47904d39586730d08 - size: 1687 + sha256: f7e45cc53601ff9f70113d0b156465f062b423ed74816159c73210a584cd9126 + size: 1853 original: - hackage: free-foil-0.0.3@sha256:cc4440d3d6ad4234611120fdecb228b621e0cabf57c1e8b8fb35282aa6fe0cfb,3134 + hackage: free-foil-0.2.0@sha256:7f99c518a63ff314c7c8ca9776625e22ef56c5170593b52c82fea6f461ac753b,3300 snapshots: - completed: sha256: 2b63732cfb5782292320fdba3920b71a2144d1265018f0312cb35b0ce04e78f5 diff --git a/test/FreeFoilTypecheck/HindleyMilner/TypecheckSpec.hs b/test/FreeFoilTypecheck/HindleyMilner/TypecheckSpec.hs new file mode 100644 index 0000000..dabdc07 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/TypecheckSpec.hs @@ -0,0 +1,77 @@ +module FreeFoilTypecheck.HindleyMilner.TypecheckSpec where + +import Control.Monad (forM_) +import qualified Control.Monad.Foil as Foil +import qualified Control.Monad.Free.Foil as Foil +import Data.List +import FreeFoilTypecheck.HindleyMilner.Interpret +import FreeFoilTypecheck.HindleyMilner.Parser.Par (myLexer, pExp, pType) +import FreeFoilTypecheck.HindleyMilner.Syntax (toExpClosed, toTypeClosed) +import FreeFoilTypecheck.HindleyMilner.Typecheck (allUVarsOfType, generalize, inferTypeNewClosed) +import System.Directory +import System.FilePath +import Test.Hspec + +spec :: Spec +spec = parallel $ do + describe "well-typed expressions" $ do + paths <- runIO (testFilesInDir "./test/FreeFoilTypecheck/HindleyMilner/files/well-typed") + forM_ (sort (filter (\p -> not (".expected.lam" `isSuffixOf` p)) paths)) $ \path -> it path $ do + contents <- readFile path + expectedTypeContents <- readFile (replaceExtension path ".expected.lam") + programTypesMatch contents expectedTypeContents `shouldBe` Right True + + describe "ill-typed expressions" $ do + paths <- runIO (testFilesInDir "./test/FreeFoilTypecheck/HindleyMilner/files/ill-typed") + forM_ (sort paths) $ \path -> it path $ do + contents <- readFile path + interpret contents `shouldSatisfy` isTypeError + +isTypeError :: Result -> Bool +isTypeError (Failure TypecheckingError _) = True +isTypeError _ = False + +testFilesInDir :: FilePath -> IO [FilePath] +testFilesInDir dir = do + let isTestFile = \f -> return $ takeExtension f == ".lam" + dirWalk isTestFile dir + +dirWalk :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath] +dirWalk filefunc top = do + isDirectory <- doesDirectoryExist top + if isDirectory + then do + -- Files preserving full path with `top` + files <- map (top ) <$> listDirectory top + paths <- mapM (dirWalk filefunc) files + return $ concat paths + else do + included <- filefunc top + return $ + if included + then [top] + else [] + +programTypesMatch :: String -> String -> Either String Bool +programTypesMatch actual expected = do + typeExpected <- toTypeClosed <$> pType tokensExpected + let vars = allUVarsOfType typeExpected + let genExpected = generalize vars typeExpected + exprActual <- toExpClosed <$> pExp tokensActual + typeActual <- inferTypeNewClosed exprActual + let vars' = allUVarsOfType typeActual + let genActual = generalize vars' typeActual + case (Foil.alphaEquiv Foil.emptyScope genActual genExpected) of + True -> Right True + False -> + Left $ + unlines + [ "types do not match", + "expected:", + show typeExpected, + "but actual is:", + show typeActual + ] + where + tokensActual = myLexer actual + tokensExpected = myLexer expected diff --git a/test/files/ill-typed/001_if.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/001_if.lam similarity index 100% rename from test/files/ill-typed/001_if.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/001_if.lam diff --git a/test/files/ill-typed/002_let_if.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/002_let_if.lam similarity index 100% rename from test/files/ill-typed/002_let_if.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/002_let_if.lam diff --git a/test/files/ill-typed/003_let_if.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/003_let_if.lam similarity index 100% rename from test/files/ill-typed/003_let_if.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/003_let_if.lam diff --git a/test/files/ill-typed/004_let_if.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/004_let_if.lam similarity index 100% rename from test/files/ill-typed/004_let_if.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/004_let_if.lam diff --git a/test/files/ill-typed/005_let_if.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/005_let_if.lam similarity index 100% rename from test/files/ill-typed/005_let_if.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/005_let_if.lam diff --git a/test/files/ill-typed/006_let_if.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/006_let_if.lam similarity index 100% rename from test/files/ill-typed/006_let_if.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/006_let_if.lam diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/007_lambda_let_typed.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/007_lambda_let_typed.lam new file mode 100644 index 0000000..ea3df86 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/007_lambda_let_typed.lam @@ -0,0 +1 @@ +λx. let y = x + 1 in y : Nat -> Bool diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/008_let_lambda.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/008_let_lambda.lam new file mode 100644 index 0000000..65ec659 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/008_let_lambda.lam @@ -0,0 +1 @@ +let f = λx. x + 1 in f true diff --git a/test/files/ill-typed/010_for-loop_typed.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/009_for-loop_typed.lam similarity index 100% rename from test/files/ill-typed/010_for-loop_typed.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/009_for-loop_typed.lam diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/010_let_lambda_partial_application.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/010_let_lambda_partial_application.lam new file mode 100644 index 0000000..3272e8e --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/010_let_lambda_partial_application.lam @@ -0,0 +1 @@ +let applfunc = λf. f 1 1 in applfunc (let func = λx. λy. x + 1 - y in func 1) \ No newline at end of file diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/011_let_lambda_app.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/011_let_lambda_app.lam new file mode 100644 index 0000000..addab8b --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/011_let_lambda_app.lam @@ -0,0 +1 @@ +let twice = λy. y y in let retone = λq.1 in twice retone twice \ No newline at end of file diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/012_let_in_let.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/012_let_in_let.lam new file mode 100644 index 0000000..a600630 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/012_let_in_let.lam @@ -0,0 +1 @@ +let f = (λx. λy. let g = x y in g) in f (λz. z + 1) false diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/013_abstration_with_let.lam b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/013_abstration_with_let.lam new file mode 100644 index 0000000..95d10ab --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/ill-typed/013_abstration_with_let.lam @@ -0,0 +1 @@ +(λx. x + (let y = (if x then 1 else 0) in y)) 1 diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/001_if.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/001_if.expected.lam new file mode 100644 index 0000000..13b3e87 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/001_if.expected.lam @@ -0,0 +1 @@ +Bool diff --git a/test/files/well-typed/001_if.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/001_if.lam similarity index 100% rename from test/files/well-typed/001_if.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/well-typed/001_if.lam diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/002_let.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/002_let.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/002_let.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/files/well-typed/002_let.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/002_let.lam similarity index 100% rename from test/files/well-typed/002_let.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/well-typed/002_let.lam diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/003_let_if.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/003_let_if.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/003_let_if.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/files/well-typed/003_let_if.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/003_let_if.lam similarity index 100% rename from test/files/well-typed/003_let_if.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/well-typed/003_let_if.lam diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/004_let_if.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/004_let_if.expected.lam new file mode 100644 index 0000000..13b3e87 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/004_let_if.expected.lam @@ -0,0 +1 @@ +Bool diff --git a/test/files/well-typed/004_let_if.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/004_let_if.lam similarity index 100% rename from test/files/well-typed/004_let_if.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/well-typed/004_let_if.lam diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/005_let_if.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/005_let_if.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/005_let_if.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/files/well-typed/005_let_if.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/005_let_if.lam similarity index 100% rename from test/files/well-typed/005_let_if.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/well-typed/005_let_if.lam diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/006_let.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/006_let.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/006_let.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/files/well-typed/006_let.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/006_let.lam similarity index 100% rename from test/files/well-typed/006_let.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/well-typed/006_let.lam diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/007_lambda_if.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/007_lambda_if.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/007_lambda_if.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/007_lambda_if.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/007_lambda_if.lam new file mode 100644 index 0000000..192e3d5 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/007_lambda_if.lam @@ -0,0 +1 @@ +(λx. if iszero (x) then 0 else x + 1) 5 diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/008_let_lambda.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/008_let_lambda.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/008_let_lambda.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/008_let_lambda.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/008_let_lambda.lam new file mode 100644 index 0000000..16fca65 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/008_let_lambda.lam @@ -0,0 +1 @@ +let f = λx. x + 1 in f 5 diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/009_let_if_lambda.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/009_let_if_lambda.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/009_let_if_lambda.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/009_let_if_lambda.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/009_let_if_lambda.lam new file mode 100644 index 0000000..d20ec0a --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/009_let_if_lambda.lam @@ -0,0 +1 @@ +let f = if iszero (5) then (λx. x) else (λx. x + 1) in f 5 diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/010_for-loop_let.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/010_for-loop_let.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/010_for-loop_let.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/files/well-typed/010_for-loop_let.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/010_for-loop_let.lam similarity index 100% rename from test/files/well-typed/010_for-loop_let.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/well-typed/010_for-loop_let.lam diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/011_for-loop.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/011_for-loop.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/011_for-loop.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/files/well-typed/011_for-loop.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/011_for-loop.lam similarity index 100% rename from test/files/well-typed/011_for-loop.lam rename to test/FreeFoilTypecheck/HindleyMilner/files/well-typed/011_for-loop.lam diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/012_let_identity.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/012_let_identity.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/012_let_identity.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/012_let_identity.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/012_let_identity.lam new file mode 100644 index 0000000..72cbf1b --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/012_let_identity.lam @@ -0,0 +1 @@ +let id = (λx. x) in ((id id) 1) diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/013_let_twice.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/013_let_twice.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/013_let_twice.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/013_let_twice.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/013_let_twice.lam new file mode 100644 index 0000000..a729d49 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/013_let_twice.lam @@ -0,0 +1,5 @@ +let twice = (λt. (λx. (t (t x)))) in + let add2 = (λx. x + 2) in + let bool2int = (λb. if b then 1 else 0) in + let not = (λb. if b then false else true) in + (twice add2) (bool2int ((twice not) true)) diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/014_nested-let.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/014_nested-let.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/014_nested-let.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/014_nested-let.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/014_nested-let.lam new file mode 100644 index 0000000..209a041 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/014_nested-let.lam @@ -0,0 +1,3 @@ +let x = 1 in + let id = λx.x + in (let x = true in id (if x then 1 else 2)) + (id x) diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/015_let_lambda_f.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/015_let_lambda_f.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/015_let_lambda_f.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/015_let_lambda_f.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/015_let_lambda_f.lam new file mode 100644 index 0000000..3c21e0f --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/015_let_lambda_f.lam @@ -0,0 +1 @@ +let twice = λy. y y in let retone = λq.λt.1 in twice retone twice \ No newline at end of file diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/016_let_lambda_partial_application.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/016_let_lambda_partial_application.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/016_let_lambda_partial_application.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/016_let_lambda_partial_application.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/016_let_lambda_partial_application.lam new file mode 100644 index 0000000..0167217 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/016_let_lambda_partial_application.lam @@ -0,0 +1 @@ +let applfunc = λf. f 2 in applfunc (let func = λx. λy. x + 1 - y in func 1) \ No newline at end of file diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/017_let_in_let_abstration.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/017_let_in_let_abstration.expected.lam new file mode 100644 index 0000000..a50d1d4 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/017_let_in_let_abstration.expected.lam @@ -0,0 +1 @@ +Nat diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/017_let_in_let_abstration.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/017_let_in_let_abstration.lam new file mode 100644 index 0000000..3ead74f --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/017_let_in_let_abstration.lam @@ -0,0 +1 @@ +let f = (λx. λy. let g = x y in g) in f (λz. z) 0 diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/018_nested_let_with_lambda_func.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/018_nested_let_with_lambda_func.expected.lam new file mode 100644 index 0000000..596b2f7 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/018_nested_let_with_lambda_func.expected.lam @@ -0,0 +1 @@ +((?x -> ?x) -> (?y -> ?y) -> ?z) -> ?z diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/018_nested_let_with_lambda_func.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/018_nested_let_with_lambda_func.lam new file mode 100644 index 0000000..f99ac84 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/018_nested_let_with_lambda_func.lam @@ -0,0 +1,3 @@ +let x0 = λz.z in + let x1 = λz.z x0 x0 in + x1 \ No newline at end of file diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/019_application_func_to_pair.expected.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/019_application_func_to_pair.expected.lam new file mode 100644 index 0000000..1ff67f2 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/019_application_func_to_pair.expected.lam @@ -0,0 +1 @@ +((?x -> ?x) -> (?x -> ?x) -> ?y) -> ?y diff --git a/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/019_application_func_to_pair.lam b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/019_application_func_to_pair.lam new file mode 100644 index 0000000..b017742 --- /dev/null +++ b/test/FreeFoilTypecheck/HindleyMilner/files/well-typed/019_application_func_to_pair.lam @@ -0,0 +1,3 @@ +let pair = λf.λs.λa. a f s in + let x1 = λy. pair y y in + x1 (λz.z) \ No newline at end of file diff --git a/test/HM/InterpretSpec.hs b/test/FreeFoilTypecheck/SystemF/InterpretSpec.hs similarity index 82% rename from test/HM/InterpretSpec.hs rename to test/FreeFoilTypecheck/SystemF/InterpretSpec.hs index 9f0f2c5..0f6627f 100644 --- a/test/HM/InterpretSpec.hs +++ b/test/FreeFoilTypecheck/SystemF/InterpretSpec.hs @@ -1,7 +1,7 @@ -module HM.InterpretSpec where +module FreeFoilTypecheck.SystemF.InterpretSpec where import Control.Monad (forM_) -import HM.Interpret +import FreeFoilTypecheck.SystemF.Interpret import System.Directory import System.FilePath import Test.Hspec @@ -9,13 +9,13 @@ import Test.Hspec spec :: Spec spec = parallel $ do describe "well-typed expressions" $ do - paths <- runIO (testFilesInDir "./test/files/well-typed") + paths <- runIO (testFilesInDir "./test/FreeFoilTypecheck/SystemF/files/well-typed") forM_ paths $ \path -> it path $ do contents <- readFile path interpret contents `shouldSatisfy` isSuccess describe "ill-typed expressions" $ do - paths <- runIO (testFilesInDir "./test/files/ill-typed") + paths <- runIO (testFilesInDir "./test/FreeFoilTypecheck/SystemF/files/ill-typed") forM_ paths $ \path -> it path $ do contents <- readFile path interpret contents `shouldSatisfy` isTypeError diff --git a/test/FreeFoilTypecheck/SystemF/files/ill-typed/001_if.lam b/test/FreeFoilTypecheck/SystemF/files/ill-typed/001_if.lam new file mode 100644 index 0000000..ab11fcb --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/ill-typed/001_if.lam @@ -0,0 +1 @@ +if (2 - (1 + true)) then true else false diff --git a/test/FreeFoilTypecheck/SystemF/files/ill-typed/002_let_if.lam b/test/FreeFoilTypecheck/SystemF/files/ill-typed/002_let_if.lam new file mode 100644 index 0000000..bb53556 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/ill-typed/002_let_if.lam @@ -0,0 +1 @@ +let x = true in (if iszero(x) then 1 else 0) diff --git a/test/FreeFoilTypecheck/SystemF/files/ill-typed/003_let_if.lam b/test/FreeFoilTypecheck/SystemF/files/ill-typed/003_let_if.lam new file mode 100644 index 0000000..d9ec7e0 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/ill-typed/003_let_if.lam @@ -0,0 +1,3 @@ +let x = 100 in + let y = false in + if iszero (y - x - x) then y + y else x + 10 diff --git a/test/FreeFoilTypecheck/SystemF/files/ill-typed/004_let_if.lam b/test/FreeFoilTypecheck/SystemF/files/ill-typed/004_let_if.lam new file mode 100644 index 0000000..f9de48a --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/ill-typed/004_let_if.lam @@ -0,0 +1,9 @@ +let x = true in + let y = false in + if x + then if y + then false + else true + else if y + then 1 + else 0 diff --git a/test/FreeFoilTypecheck/SystemF/files/ill-typed/005_let_if.lam b/test/FreeFoilTypecheck/SystemF/files/ill-typed/005_let_if.lam new file mode 100644 index 0000000..df52442 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/ill-typed/005_let_if.lam @@ -0,0 +1,4 @@ +let x = true in + if x + x + then 1 + else false diff --git a/test/FreeFoilTypecheck/SystemF/files/ill-typed/006_let_if.lam b/test/FreeFoilTypecheck/SystemF/files/ill-typed/006_let_if.lam new file mode 100644 index 0000000..aa7dbc8 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/ill-typed/006_let_if.lam @@ -0,0 +1 @@ +(0 + (2 - 33 + (let x = 3 in x - (let y = true in if iszero(0) then if y then 1 else 0 else true)))) diff --git a/test/files/ill-typed/007_lambda_let_typed.lam b/test/FreeFoilTypecheck/SystemF/files/ill-typed/007_lambda_let_typed.lam similarity index 100% rename from test/files/ill-typed/007_lambda_let_typed.lam rename to test/FreeFoilTypecheck/SystemF/files/ill-typed/007_lambda_let_typed.lam diff --git a/test/files/ill-typed/008_let_lambda.lam b/test/FreeFoilTypecheck/SystemF/files/ill-typed/008_let_lambda.lam similarity index 100% rename from test/files/ill-typed/008_let_lambda.lam rename to test/FreeFoilTypecheck/SystemF/files/ill-typed/008_let_lambda.lam diff --git a/test/files/ill-typed/009_let_if_lambda.lam b/test/FreeFoilTypecheck/SystemF/files/ill-typed/009_let_if_lambda.lam similarity index 100% rename from test/files/ill-typed/009_let_if_lambda.lam rename to test/FreeFoilTypecheck/SystemF/files/ill-typed/009_let_if_lambda.lam diff --git a/test/FreeFoilTypecheck/SystemF/files/ill-typed/010_for-loop_typed.lam b/test/FreeFoilTypecheck/SystemF/files/ill-typed/010_for-loop_typed.lam new file mode 100644 index 0000000..a628410 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/ill-typed/010_for-loop_typed.lam @@ -0,0 +1,2 @@ +for x in [0..1] do + 1+x : Bool diff --git a/test/FreeFoilTypecheck/SystemF/files/ill-typed/011_bidirectional.lam b/test/FreeFoilTypecheck/SystemF/files/ill-typed/011_bidirectional.lam new file mode 100644 index 0000000..9bd1b12 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/ill-typed/011_bidirectional.lam @@ -0,0 +1 @@ +if false then (λf:Bool. f) else (λx. x + 2) \ No newline at end of file diff --git a/test/FreeFoilTypecheck/SystemF/files/well-typed/001_if.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/001_if.lam new file mode 100644 index 0000000..a9cb3f7 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/well-typed/001_if.lam @@ -0,0 +1 @@ +if iszero (2 - (1 + 1)) then true else false diff --git a/test/FreeFoilTypecheck/SystemF/files/well-typed/002_let.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/002_let.lam new file mode 100644 index 0000000..4bd495e --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/well-typed/002_let.lam @@ -0,0 +1 @@ +let x = 1 in let y = 2 in x + (let x = 3 in x + y) diff --git a/test/FreeFoilTypecheck/SystemF/files/well-typed/003_let_if.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/003_let_if.lam new file mode 100644 index 0000000..560d6ef --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/well-typed/003_let_if.lam @@ -0,0 +1,3 @@ +let x = 100 in + let y = 200 in + if iszero (y - x - x) then y + y else x + 10 diff --git a/test/FreeFoilTypecheck/SystemF/files/well-typed/004_let_if.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/004_let_if.lam new file mode 100644 index 0000000..250db61 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/well-typed/004_let_if.lam @@ -0,0 +1,9 @@ +let x = true in + let y = false in + if x + then if y + then false + else true + else if y + then true + else false diff --git a/test/FreeFoilTypecheck/SystemF/files/well-typed/005_let_if.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/005_let_if.lam new file mode 100644 index 0000000..1ea297c --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/well-typed/005_let_if.lam @@ -0,0 +1,6 @@ +let x = 3 in + if true + then let y = 3 in + x + y + else let y = 2 in + x - y diff --git a/test/FreeFoilTypecheck/SystemF/files/well-typed/006_let.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/006_let.lam new file mode 100644 index 0000000..9cddfa6 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/well-typed/006_let.lam @@ -0,0 +1 @@ +1 + (let x = 1 in let y = false in let z = 4 in x + z + (if y then 1 else 5)) diff --git a/test/files/well-typed/007_lambda_if.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/007_lambda_if.lam similarity index 100% rename from test/files/well-typed/007_lambda_if.lam rename to test/FreeFoilTypecheck/SystemF/files/well-typed/007_lambda_if.lam diff --git a/test/files/well-typed/008_let_lambda.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/008_let_lambda.lam similarity index 100% rename from test/files/well-typed/008_let_lambda.lam rename to test/FreeFoilTypecheck/SystemF/files/well-typed/008_let_lambda.lam diff --git a/test/files/well-typed/009_let_if_lambda.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/009_let_if_lambda.lam similarity index 100% rename from test/files/well-typed/009_let_if_lambda.lam rename to test/FreeFoilTypecheck/SystemF/files/well-typed/009_let_if_lambda.lam diff --git a/test/FreeFoilTypecheck/SystemF/files/well-typed/010_for-loop_let.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/010_for-loop_let.lam new file mode 100644 index 0000000..864d683 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/well-typed/010_for-loop_let.lam @@ -0,0 +1,2 @@ +for i in [1..5] do + let x = 10 - i in x + (let y = 1 in x + y) diff --git a/test/FreeFoilTypecheck/SystemF/files/well-typed/011_for-loop.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/011_for-loop.lam new file mode 100644 index 0000000..21682e3 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/well-typed/011_for-loop.lam @@ -0,0 +1,2 @@ +for i in [1..5] do + 10 - i diff --git a/test/FreeFoilTypecheck/SystemF/files/well-typed/012_system-f.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/012_system-f.lam new file mode 100644 index 0000000..4ff48b0 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/well-typed/012_system-f.lam @@ -0,0 +1 @@ +let id = (ΛX. λx:X. x) in id : forall Y. Y -> Y diff --git a/test/FreeFoilTypecheck/SystemF/files/well-typed/013_bidirectional.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/013_bidirectional.lam new file mode 100644 index 0000000..a55762f --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/well-typed/013_bidirectional.lam @@ -0,0 +1 @@ +if false then (λf. if f then 0 else 1) else (λx. 1) : Bool -> Nat diff --git a/test/FreeFoilTypecheck/SystemF/files/well-typed/014_let_bidirectional.lam b/test/FreeFoilTypecheck/SystemF/files/well-typed/014_let_bidirectional.lam new file mode 100644 index 0000000..0829295 --- /dev/null +++ b/test/FreeFoilTypecheck/SystemF/files/well-typed/014_let_bidirectional.lam @@ -0,0 +1 @@ +(let const = 1 in λf. const) : Bool -> Nat diff --git a/test/doctests/Main.hs b/test/doctests/Main.hs index 758d6d8..ab0f151 100644 --- a/test/doctests/Main.hs +++ b/test/doctests/Main.hs @@ -4,4 +4,4 @@ import System.Environment (getArgs) import Test.DocTest (mainFromCabal) main :: IO () -main = mainFromCabal "free-foil-hm" =<< getArgs +main = mainFromCabal "free-foil-typecheck" =<< getArgs