diff --git a/C.grm b/C.grm
new file mode 100644
--- /dev/null
+++ b/C.grm
@@ -0,0 +1,85 @@
+data Module
+ | HModule "#ifndef" uident "\n#define" uident "\n" ImportList DeclareList "\n#endif"
+ | CModule ImportList DefineList
+
+data Import
+ | Import "#include" string
+ | GImport "#include" "<" "" lident "" ">"
+
+data Declare
+ | Declare FunDecl
+ | Typedef "typedef" Decl
+
+data Define
+ | Define FunDecl "{" StmtList "}"
+
+data FunDecl
+ | FunFD Type lident "" "(" "" ArgDeclList "" ")"
+ | RetFunFD Type "(" "*" lident "(" "" ArgDeclList "" ")" ")" "(" "" TypeList "" ")"
+
+data Type
+ | TyName uident
+ | TyPtr Type "" "*"
+ | TyFun Type "(" "" "*" "" ")" "(" "" TypeList "" ")"
+ | TyArray Type "[" number "]"
+ | TyEnum "enum" "{" EnumCList "}"
+ | TyStruct "struct" "{" DeclList "}"
+ | TyUnion "union" "{" DeclList "}"
+
+data EnumC | EnumC uident
+
+data Decl
+ | Decl Type lident
+ | FunD Type lident "" "(" "" TypeList "" ")"
+
+data Exp
+ | AllocaE "alloca" "(" "sizeof" "(" Type ")" ")"
+ | VarE lident
+ | LitE Lit
+ | CastE "(" Type ")" Exp
+ | LoadE "*" "" Exp
+ | ArrowE Exp "" "->" "" Exp
+ | DotE Exp "" "." "" Exp
+ | AddrE "&" "" Exp
+ | IdxE Exp "" "[" "" Exp "" "]"
+ | CallE Exp "" "(" "" ExpList "" ")"
+ | BinOpE "(" "" Exp usym Exp "" ")"
+ | ParenE "(" Exp ")"
+ | NotE "!" "" Exp
+
+data Stmt
+ | DeclS Decl
+ | AssignS Exp "=" Exp
+ | CallS Exp "" "(" "" ExpList "" ")"
+ | SwitchS "switch" "(" Exp ")" "{" SwitchAltList "}"
+ | BreakS "break"
+ | IfS "if" "(" Exp ")" "{" StmtList "}" "else" "{" StmtList "}"
+ | WhenS "if" "(" Exp ")" "{" StmtList "}"
+ | WhileS "while" "(" Exp ")" "{" StmtList "}"
+ | ReturnS "return" "" "(" "" Exp "" ")"
+ | RetVoidS "return"
+ | NoOpS
+ | BlockS StmtList
+ | IncS Exp "" "++"
+ | DecS Exp "" "--"
+
+data SwitchAlt
+ | SwitchAlt "case" Lit "" ":" StmtList
+ | DefaultAlt "default:" StmtList
+
+data Lit
+ | StringL string
+ | CharL char
+ | NmbrL number
+ | EnumL uident
+
+list TypeList Type empty separator "," horiz
+list ExpList Exp nonempty separator "," horiz
+list EnumCList EnumC nonempty separator "," horiz
+list DeclList Decl empty terminator ";" horiz
+list ArgDeclList Decl empty separator "," horiz
+list SwitchAltList SwitchAlt empty terminator "" vert
+list StmtList Stmt empty terminator ";" vert
+list DeclareList Declare empty terminator ";" vert
+list DefineList Define empty terminator ";" vert
+list ImportList Import empty terminator "" vert
diff --git a/CHANGES b/CHANGES
new file mode 100644
--- /dev/null
+++ b/CHANGES
@@ -0,0 +1,7 @@
+Changes since the last release:
+ - eliminated inline Haskell code in pec syntax (that was an ugly idea :)
+ - rewrite to better support multiple backends
+ - added C backend support
+ - now using grm instead of bnfc
+ - added stack, queue, deque container types to pec lib
+ - more test cases including some project euler
diff --git a/DESIGN b/DESIGN
--- a/DESIGN
+++ b/DESIGN
@@ -1,103 +1,71 @@
-INTRO
-
-Pec is a strict, impure, procedural language. It is intended to have
-the look and feel of Haskell and compile to LLVM and C. It is
-strongly influenced by all three languages:
-
-Haskell
- - Strong typing with Hindley-Milner type inference
- - Variants, tuples, records
- - case expressions, pattern matching
- - User defined, polymorphic data structures
- - Parametric polymorphism, ad-hoc polymorphism, laziness,
- user-defined operators, etc. (provided via Haskell DSL)
- - Modules
- - Syntax/Layout
- - productive
-
-LLVM & C
- - compiles to LLVM (C planned)
- - easy integration
- - efficient
- - simple run-time system
- - arbitrary sized integers
- - single static assignment (SSA) names
- - no garbage collection
- - no closures
- - no objects
-
-Pec
- - small syntax
- - safe pointers
- - type system prevents out of bounds array indexing
- - no recursion
- - no operator precedence
-
-LANGUAGE ARCHITECTURE
-
-pec is made up of two sub-languages, the pec "application" language and
-the pec "library" DSL. In this sense it is very similar to the
-relationship between C and the C pre-processor (although the "library"
-DSL should provide a dramatically better user experience than cpp).
-The intent is that the majority of code will be written in the
-"application" language by application programmers. "Library" code
-(code that needs parametric polymorphism and other advanced features)
-will be written by library programmers that know both pec and Haskell
-and understand the provided DSL. In fact, the goal is to offload as
-much as possible from the pec compiler to the libraries (e.g. type
-bool is implemented in a library). These two types of code can be
-interspersed in a single .pec file.
-
-Syntax for the "application" language is contained in the pec.cf file.
-This file used by bnfc to automatically derive a lexer and a parser
-for the language. The precise syntax for the "application" language
-can be found in Language/Pec/Doc.html.
-
-Syntax for the "library" language is simply Haskell
-syntax prefixed by a '>' at the start of a line.
-
-Check out the .pec files in the test directory to get a better feel
-for how pec works.
-
-COMPILER ARCHITECTURE
-
-The pec compiler leverages several tools in its compilation pipeline.
-This allows the compiler to be small and nimble (but can also have
-drawbacks, e.g. error messages).
-
-Main.hs implements the compiler pipeline. Pec/Base.hs is the code
-generation library used by the generated Haskell modules. It also
-provides the pec "library" DSL.
-
-Pec compilation begins by specifying the "main" pec module on the
-command line.
-
- e.g. pec Foo.pec
-
-The main module is parsed and its import dependencies are noted. This
-is then repeated recursively for each dependency.
-
- e.g. Foo.pec, Bar.pec, Baz.pec
-
-These pec modules are all transformed to corresponding Haskell modules
-and a "main" Haskell module. These Haskell modules contain the code
-needed to generate the goal LLVM/C code. They also contain enough
-type information for the ghc type inference/checking to be leveraged.
-
- e.g. Foo_.hs, Bar_.hs, Baz_.hs, Foo_main.hs
-
-ghc is then used to infer/check types and build the code generation
-executable.
-
- e.g. ghc --make Foo_main.hs
-
-When run, the resulting executable will create corresponding LLVM IR
-modules.
-
- e.g. Foo.ll, Bar.ll, Baz.ll
-
-LLVM is then used to transform the LLVM IR into LLVM bitcode and from
-there to the desired executable.
-
-The pec compiler doesn't currently generate C, but that is high on the
-TODO list.
+INTRO
+
+Pec is a strict, impure, procedural language. It is intended to have
+the look and feel of Haskell and compile to LLVM and C. It is
+strongly influenced by all three languages:
+
+Haskell
+ - Strong typing with Hindley-Milner type inference
+ - Variants, tuples, records
+ - case expressions, pattern matching
+ - User defined, polymorphic data structures
+ - Parametric polymorphism, limited ad-hoc polymorphism
+ - Modules
+ - Syntax/Layout
+ - productive
+
+LLVM & C
+ - compiles to C & LLVM
+ - easy integration
+ - efficient
+ - simple run-time system
+ - arbitrary sized integers (LLVM)
+ - single static assignment (SSA) names
+ - no garbage collection
+ - no closures
+ - no objects
+
+Pec
+ - small syntax
+ - safe pointers
+ - type system prevents out of bounds array indexing
+ - no recursion
+ - no operator precedence
+
+COMPILER ARCHITECTURE
+
+The pec compiler leverages several tools in its compilation pipeline.
+This allows the compiler to be small and nimble (but can also have
+drawbacks, e.g. error messages).
+
+src/Pec.hs implements the compiler pipeline. Pec/Base.hs is the code
+generation library used by the generated Haskell modules.
+
+Pec compilation begins by specifying the "main" pec module on the
+command line.
+
+ e.g. pec Foo.pec
+
+The main module is parsed and its import dependencies are noted. This
+is then repeated recursively for each dependency.
+
+ e.g. Foo.pec, Bar.pec, Baz.pec
+
+These pec modules are all transformed to corresponding Haskell modules
+and a "main" Haskell module. These Haskell modules contain the code
+needed to generate the goal LLVM/C code. They also contain enough
+type information for the ghc type inference/checking to be leveraged.
+
+ e.g. Foo_.hs, Bar_.hs, Baz_.hs, Foo_main.hs
+
+ghc is then used to infer/check types and build the code generation
+executable.
+
+ e.g. ghc --make Foo_main.hs
+
+When run, the resulting executable will create corresponding LLVM IR
+modules or C modules.
+
+ e.g. Foo.ll, Bar.ll, Baz.ll
+
+LLVM/gcc are then used to transform the code into the desired executable.
diff --git a/FAQ b/FAQ
--- a/FAQ
+++ b/FAQ
@@ -1,82 +1,101 @@
-The pec programming language FAQ
-
-Q: How mature is pec?
-
-A: It's not :) Good ideas/help is appreciated in all areas, from
-language design, implementation, test cases, etc. That being said,
-you should be able to use the pec compiler to write fairly
-sophisticated prototype applications (see examples in the test case
-directory). Comments/questions/bug reports can be sent to brettletner
-at gmail dot com.
-
-Q: Where did the name 'pec' come from?
-
-A: A long time ago it stood for Pure Embedded Compiler. pec is no
-longer pure, but I still liked the name. Now I guess it stands for
-pec embedded compiler :)
-
-Q: Why isn't pec pure?
-
-A: Mostly I wanted to make it easier for C programmers to migrate. A
-pure language with the same target market seems like a fine thing,
-though.
-
-Q: How does the type system prevent out of bounds array indexing?
-
-A: It uses Haskell classes and built-in "Count" types. See the paper
-"Lightweight static capabilities" by Kiselyov and Shan for more
-information.
-
-Q: Can I use the type system to prevent other common sources of
-errors, e.g. divide by zero?
-
-A: Yes.
-
-Q: Why no garbage collection?
-
-A: GC is generally (right or wrong) frowned upon in embedded
-development. It makes the run-time system more complicated and
-makes integration with other GC'd languages more difficult. A GC'd
-language with the same target market seems like a fine thing, though.
-
-Q: Why no recursion?
-
-A: Recursion is generally (right or wrong) frowned upon in embedded
-development. Also, not having recursion leaves open the possibility
-of compiling the whole program into a state machine.
-
-Q: Why no closures?
-
-A: Pec doesn't have a heap, so it can't have "upward"
-closures. "Downward" closures may be added in the future.
-
-Q: Why no objects?
-
-A: Personal preference.
-
-Q: Why no parallelism/concurrency?
-
-A: I just haven't thought about it yet. My best guess is that it will
-eventually be based on STM, but help is needed here.
-
-Q: Why no operator precedence?
-
-A: It is better style to just put the parens in and removes all code
-review discussion as to whether you should have parens or not. Also,
-I was too lazy to implement it :)
-
-Q: This "safe" pointer isn't safe at all, what gives?
-
-foo = do
- p = new (Just 'a')
- case p of
- Nothing -> ()
- Just c -> do
- p <- Nothing
- putCh @c
-
-A: The second assignment to p (i.e. p <- Nothing) should be disallowed
-while c is in scope. The compiler currently doesn't prevent this (and
-other similar errors such as returning a pointer to the (soon to be
-invalidated) stack). If anyone has an idea on how to prevent this I'd
-love to hear it.
+The pec programming language FAQ
+
+Q: How mature is pec?
+
+A: It's not :) Good ideas/help is appreciated in all areas, from
+language design, implementation, test cases, etc. That being said,
+you should be able to use the pec compiler to write prototype
+applications (see examples in the test case directory).
+Comments/questions/bug reports can be sent to brettletner at gmail dot
+com.
+
+Q: Where did the name 'pec' come from?
+
+A: A long time ago it stood for Pure Embedded Compiler. pec is no
+longer pure, but I still liked the name. Now I guess it stands for
+pec embedded compiler :)
+
+Q: Why isn't pec pure?
+
+A: Mostly I wanted to make it easier for C programmers to migrate. A
+pure language with the same target market seems like a fine thing,
+though.
+
+Q: How does the type system prevent out of bounds array indexing?
+
+A: It uses Haskell classes and built-in "Count" types. See the paper
+"Lightweight static capabilities" by Kiselyov and Shan for more
+information.
+
+Q: Can I use the type system to prevent other common sources of
+errors, e.g. divide by zero?
+
+A: Yes.
+
+Q: Why no garbage collection?
+
+A: GC is generally (right or wrong) frowned upon in embedded
+development. It makes the run-time system more complicated and
+makes integration with other GC'd languages more difficult. A GC'd
+language with the same target market seems like a fine thing, though.
+
+Q: Why no recursion?
+
+A: Recursion is generally (right or wrong) frowned upon in embedded
+development. Also, not having (general) recursion leaves open the
+possibility of compiling the whole program into a state machine.
+
+Q: Why no closures?
+
+A: Pec doesn't have a heap, so it can't have "upward" closures.
+"Downward" closures may be added in the future. It does have a simple
+form of macro lambda.
+
+Q: Why no objects?
+
+A: Personal preference.
+
+Q: Why no parallelism/concurrency?
+
+A: I just haven't thought about it yet. My best guess is that it will
+eventually be based on STM, but help is needed here.
+
+Q: Why no operator precedence?
+
+A: It is better style to just put the parens in and removes all code
+review discussion as to whether you should have parens or not. Also,
+I was too lazy to implement it :)
+
+Q: This "safe" pointer isn't safe at all, what gives?
+
+foo = do
+ p = new (Just 'a')
+ case p of
+ Nothing -> ()
+ Just c -> do
+ p <- Nothing
+ putCh @c
+
+A: The second assignment to p (i.e. p <- Nothing) should be disallowed
+while c is in scope. The compiler currently doesn't prevent this (and
+other similar errors such as returning a pointer to the (soon to be
+invalidated) stack). If anyone has an idea on how to statically
+prevent this I'd love to hear it.
+
+Q: Why does the pec parser take so long to compile?
+
+A: I don't know. Help on this from a 'happy' expert would be much
+appreciated.
+
+Q: How do I modify the pec grammar?
+
+A: You'll need my compiler construction tool, 'grm'. Grm is similar
+to bnfc in that it will generate a parser, pretty printer, and AST
+from an input grammar file (e.g. pec.grm). Grm can be found on
+hackage and git@github.com:stevezhee/grm.git.
+
+Q: At least one of the examples in the euler directory (Euler10.pec)
+takes a very long time (infinity?) to compile under LLVM. Why?
+
+A: I don't know. Help on this from a llvm/llc expert would be much
+appreciated.
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,30 +1,30 @@
-Copyright (c)2011, Brett Letner
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Brett Letner nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+Copyright (c)2011-2012, Brett Letner
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Brett Letner nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/LLVM.grm b/LLVM.grm
new file mode 100644
--- /dev/null
+++ b/LLVM.grm
@@ -0,0 +1,131 @@
+data Module
+ | Module DefineList
+
+data Define
+ | Define "define" Type lident "(" TVarList ")" "{" StmtList "}"
+ | Declare "declare" Type lident "(" TypeList ")"
+ | TypeD lident "=" "type" Type
+ | StringD lident "= private constant [" number "x i8 ] c" "" "\"" "" lident "" "\\00\""
+
+data Stmt
+ | LetS lident "=" Exp
+ | StoreS "store" Atom "" "," TVar
+ | CallS "call" TVar "(" AtomList ")"
+ | SwitchS "switch" Atom "" ", label %" "" lident "[" SwitchAltList "]"
+ | ReturnS "ret" Atom
+ | LabelS lident "" ":"
+ | BrS "br i1" UAtom "" ", label %" "" lident "" ", label %" "" lident
+ | Br0S "br label %" "" lident
+ | TagS "store" Atom "" ","
+ | NoOpS ";"
+
+data Exp
+ | CallE "call" TVar "(" AtomList ")"
+ | CastE Cast TVar "to" Type
+ | AllocaE "alloca" Type
+ | LoadE "load" TVar
+ | AtomE Atom
+ | BinOpE BinOp Type UAtom "" "," UAtom
+ | IdxE "getelementptr inbounds" TVar "" ", i32 0," Atom
+
+data Cast
+ | Bitcast "bitcast"
+ | Sitofp "sitofp"
+ | Uitofp "uitofp"
+ | Fptosi "fptosi"
+ | Fptoui "fptoui"
+ | Trunc "trunc"
+ | Zext "zext"
+ | Sext "sext"
+ | Fptrunc "fptrunc"
+ | Fpext "fpext"
+
+data BinOp
+ | Icmp "icmp" ICond
+ | Fcmp "fcmp" FCond
+ | Add "add nuw nsw"
+ | Fadd "fadd"
+ | Sub "sub nuw nsw"
+ | Fsub "fsub"
+ | Mul "mul nuw nsw"
+ | Fmul "fmul"
+ | Udiv "udiv"
+ | Sdiv "sdiv"
+ | Fdiv "fdiv"
+ | Urem "urem"
+ | Srem "srem"
+ | Frem "frem"
+ | Shl "shl"
+ | Lshr "lshr"
+ -- | Ashr "ashr"
+ | And "and"
+ | Or "or"
+ | Xor "xor"
+
+data Atom
+ | LitA TLit
+ | VarA TVar
+
+data UAtom
+ | LitUA Lit
+ | VarUA lident
+
+data ICond
+ | Equ "eq"
+ | Neq "ne"
+ | Ugt "ugt"
+ | Sgt "sgt"
+ | Uge "uge"
+ | Sge "sge"
+ | Ult "ult"
+ | Slt "slt"
+ | Ule "ule"
+ | Sle "sle"
+
+data FCond
+ | Ogt "ogt"
+ | Oge "oge"
+ | Olt "olt"
+ | Ole "ole"
+ -- | Oeq "oeq"
+ -- | One "one"
+
+data SwitchAlt | SwitchAlt TLit "" ", label %" "" lident
+
+data Lit
+ | NmbrL number
+ | FalseL "false"
+ | TrueL "true"
+ | StringL "getelementptr inbounds ([" number "x i8 ]*" lident "" ", i32 0, i32 0)"
+ | VoidL
+
+data TVar | TVar Type lident
+
+data TLit | TLit Type Lit
+
+data FieldT | FieldT uident "::" Type
+
+data ConC | ConC uident Type
+
+data Type
+ | PtrT Type "" "*"
+ | IntT "i" "" number
+ | FloatT "float"
+ | DoubleT "double"
+ | VoidT "void"
+ | FunT Type "(" TypeList ")"
+ | VarArgsT "..."
+ | UserT lident
+ | StructT "{" TypeList "}"
+ | ArrayT "[" number "x" Type "]"
+ | CharT "i8"
+
+list ConCList ConC nonempty separator "|" horiz
+list FieldTList FieldT nonempty separator "," horiz
+list TypeList Type empty separator "," horiz
+list ExpList Exp nonempty separator "," horiz
+list AtomList Atom nonempty separator "," horiz
+list TVarList TVar nonempty separator "," horiz
+list SwitchAltList SwitchAlt empty terminator "" vert
+list StmtList Stmt empty terminator "" vert
+list DefineList Define empty terminator "" vert
diff --git a/Language/C/Abs.hs b/Language/C/Abs.hs
new file mode 100644
--- /dev/null
+++ b/Language/C/Abs.hs
@@ -0,0 +1,194 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module Language.C.Abs where
+import Control.DeepSeq
+import Data.Generics
+import Grm.Prims
+import Grm.Lex
+import Text.PrettyPrint.Leijen
+myLexemes = ["\n","\n#define","\n#endif","!","#ifndef","#include","&","(",")","*","++",",","--","->",".",":",";","<","=",">","[","]","alloca","break","case","default:","else","enum","if","return","sizeof","struct","switch","typedef","union","while","{","}"]
+grmLexFilePath = lexFilePath myLexemes
+grmLexContents = lexContents myLexemes
+data Module
+ = HModule Uident Uident ImportList DeclareList
+ | CModule ImportList DefineList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Import
+ = Import String
+ | GImport Lident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Declare
+ = Declare FunDecl
+ | Typedef Decl
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Define
+ = Define FunDecl StmtList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data FunDecl
+ = FunFD Type Lident ArgDeclList
+ | RetFunFD Type Lident ArgDeclList TypeList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Type
+ = TyName Uident
+ | TyPtr Type
+ | TyFun Type TypeList
+ | TyArray Type Number
+ | TyEnum EnumCList
+ | TyStruct DeclList
+ | TyUnion DeclList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data EnumC
+ = EnumC Uident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Decl
+ = Decl Type Lident
+ | FunD Type Lident TypeList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Exp
+ = AllocaE Type
+ | VarE Lident
+ | LitE Lit
+ | CastE Type Exp
+ | LoadE Exp
+ | ArrowE Exp Exp
+ | DotE Exp Exp
+ | AddrE Exp
+ | IdxE Exp Exp
+ | CallE Exp ExpList
+ | BinOpE Exp Usym Exp
+ | ParenE Exp
+ | NotE Exp
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Stmt
+ = DeclS Decl
+ | AssignS Exp Exp
+ | CallS Exp ExpList
+ | SwitchS Exp SwitchAltList
+ | BreakS
+ | IfS Exp StmtList StmtList
+ | WhenS Exp StmtList
+ | WhileS Exp StmtList
+ | ReturnS Exp
+ | RetVoidS
+ | NoOpS
+ | BlockS StmtList
+ | IncS Exp
+ | DecS Exp
+ deriving (Show,Eq,Ord,Data,Typeable)
+data SwitchAlt
+ = SwitchAlt Lit StmtList
+ | DefaultAlt StmtList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Lit
+ = StringL String
+ | CharL Char
+ | NmbrL Number
+ | EnumL Uident
+ deriving (Show,Eq,Ord,Data,Typeable)
+type TypeList = [Type ]
+type ExpList = [Exp ]
+type EnumCList = [EnumC ]
+type DeclList = [Decl ]
+type ArgDeclList = [Decl ]
+type SwitchAltList = [SwitchAlt ]
+type StmtList = [Stmt ]
+type DeclareList = [Declare ]
+type DefineList = [Define ]
+type ImportList = [Import ]
+instance Pretty (Module ) where
+ pretty = ppModule
+ppModule x = case x of
+ HModule v1 v2 v3 v4 -> text "#ifndef" <+> ppUident v1 <+> text "\n#define" <+> ppUident v2 <+> text "\n" <+> ppImportList v3 <+> ppDeclareList v4 <+> text "\n#endif"
+ CModule v1 v2 -> ppImportList v1 <+> ppDefineList v2
+instance Pretty (Import ) where
+ pretty = ppImport
+ppImport x = case x of
+ Import v1 -> text "#include" <+> ppString v1
+ GImport v1 -> text "#include" <+> text "<" <> ppLident v1 <> text ">"
+instance Pretty (Declare ) where
+ pretty = ppDeclare
+ppDeclare x = case x of
+ Declare v1 -> ppFunDecl v1
+ Typedef v1 -> text "typedef" <+> ppDecl v1
+instance Pretty (Define ) where
+ pretty = ppDefine
+ppDefine x = case x of
+ Define v1 v2 -> ppFunDecl v1 <+> text "{" <+> ppStmtList v2 <+> text "}"
+instance Pretty (FunDecl ) where
+ pretty = ppFunDecl
+ppFunDecl x = case x of
+ FunFD v1 v2 v3 -> ppType v1 <+> ppLident v2 <> text "(" <> ppArgDeclList v3 <> text ")"
+ RetFunFD v1 v2 v3 v4 -> ppType v1 <+> text "(" <+> text "*" <+> ppLident v2 <+> text "(" <> ppArgDeclList v3 <> text ")" <+> text ")" <+> text "(" <> ppTypeList v4 <> text ")"
+instance Pretty (Type ) where
+ pretty = ppType
+ppType x = case x of
+ TyName v1 -> ppUident v1
+ TyPtr v1 -> ppType v1 <> text "*"
+ TyFun v1 v2 -> ppType v1 <+> text "(" <> text "*" <> text ")" <+> text "(" <> ppTypeList v2 <> text ")"
+ TyArray v1 v2 -> ppType v1 <+> text "[" <+> ppNumber v2 <+> text "]"
+ TyEnum v1 -> text "enum" <+> text "{" <+> ppEnumCList v1 <+> text "}"
+ TyStruct v1 -> text "struct" <+> text "{" <+> ppDeclList v1 <+> text "}"
+ TyUnion v1 -> text "union" <+> text "{" <+> ppDeclList v1 <+> text "}"
+instance Pretty (EnumC ) where
+ pretty = ppEnumC
+ppEnumC x = case x of
+ EnumC v1 -> ppUident v1
+instance Pretty (Decl ) where
+ pretty = ppDecl
+ppDecl x = case x of
+ Decl v1 v2 -> ppType v1 <+> ppLident v2
+ FunD v1 v2 v3 -> ppType v1 <+> ppLident v2 <> text "(" <> ppTypeList v3 <> text ")"
+instance Pretty (Exp ) where
+ pretty = ppExp
+ppExp x = case x of
+ AllocaE v1 -> text "alloca" <+> text "(" <+> text "sizeof" <+> text "(" <+> ppType v1 <+> text ")" <+> text ")"
+ VarE v1 -> ppLident v1
+ LitE v1 -> ppLit v1
+ CastE v1 v2 -> text "(" <+> ppType v1 <+> text ")" <+> ppExp v2
+ LoadE v1 -> text "*" <> ppExp v1
+ ArrowE v1 v2 -> ppExp v1 <> text "->" <> ppExp v2
+ DotE v1 v2 -> ppExp v1 <> text "." <> ppExp v2
+ AddrE v1 -> text "&" <> ppExp v1
+ IdxE v1 v2 -> ppExp v1 <> text "[" <> ppExp v2 <> text "]"
+ CallE v1 v2 -> ppExp v1 <> text "(" <> ppExpList v2 <> text ")"
+ BinOpE v1 v2 v3 -> text "(" <> ppExp v1 <+> ppUsym v2 <+> ppExp v3 <> text ")"
+ ParenE v1 -> text "(" <+> ppExp v1 <+> text ")"
+ NotE v1 -> text "!" <> ppExp v1
+instance Pretty (Stmt ) where
+ pretty = ppStmt
+ppStmt x = case x of
+ DeclS v1 -> ppDecl v1
+ AssignS v1 v2 -> ppExp v1 <+> text "=" <+> ppExp v2
+ CallS v1 v2 -> ppExp v1 <> text "(" <> ppExpList v2 <> text ")"
+ SwitchS v1 v2 -> text "switch" <+> text "(" <+> ppExp v1 <+> text ")" <+> text "{" <+> ppSwitchAltList v2 <+> text "}"
+ BreakS -> text "break"
+ IfS v1 v2 v3 -> text "if" <+> text "(" <+> ppExp v1 <+> text ")" <+> text "{" <+> ppStmtList v2 <+> text "}" <+> text "else" <+> text "{" <+> ppStmtList v3 <+> text "}"
+ WhenS v1 v2 -> text "if" <+> text "(" <+> ppExp v1 <+> text ")" <+> text "{" <+> ppStmtList v2 <+> text "}"
+ WhileS v1 v2 -> text "while" <+> text "(" <+> ppExp v1 <+> text ")" <+> text "{" <+> ppStmtList v2 <+> text "}"
+ ReturnS v1 -> text "return" <> text "(" <> ppExp v1 <> text ")"
+ RetVoidS -> text "return"
+ NoOpS -> Text.PrettyPrint.Leijen.empty
+ BlockS v1 -> ppStmtList v1
+ IncS v1 -> ppExp v1 <> text "++"
+ DecS v1 -> ppExp v1 <> text "--"
+instance Pretty (SwitchAlt ) where
+ pretty = ppSwitchAlt
+ppSwitchAlt x = case x of
+ SwitchAlt v1 v2 -> text "case" <+> ppLit v1 <> text ":" <+> ppStmtList v2
+ DefaultAlt v1 -> text "default:" <+> ppStmtList v1
+instance Pretty (Lit ) where
+ pretty = ppLit
+ppLit x = case x of
+ StringL v1 -> ppString v1
+ CharL v1 -> ppChar v1
+ NmbrL v1 -> ppNumber v1
+ EnumL v1 -> ppUident v1
+ppTypeList = ppList ppType Separator "," Horiz
+ppExpList = ppList ppExp Separator "," Horiz
+ppEnumCList = ppList ppEnumC Separator "," Horiz
+ppDeclList = ppList ppDecl Terminator ";" Horiz
+ppArgDeclList = ppList ppDecl Separator "," Horiz
+ppSwitchAltList = ppList ppSwitchAlt Terminator "" Vert
+ppStmtList = ppList ppStmt Terminator ";" Vert
+ppDeclareList = ppList ppDeclare Terminator ";" Vert
+ppDefineList = ppList ppDefine Terminator ";" Vert
+ppImportList = ppList ppImport Terminator "" Vert
diff --git a/Language/LLVM/Abs.hs b/Language/LLVM/Abs.hs
new file mode 100644
--- /dev/null
+++ b/Language/LLVM/Abs.hs
@@ -0,0 +1,293 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module Language.LLVM.Abs where
+import Control.DeepSeq
+import Data.Generics
+import Grm.Prims
+import Grm.Lex
+import Text.PrettyPrint.Leijen
+myLexemes = ["\"","(",")","*",",",", i32 0,",", i32 0, i32 0)",", label %","...",":","::",";","=","= private constant [","[","\\00\"","]","add nuw nsw","alloca","and","bitcast","br i1","br label %","call","declare","define","double","eq","fadd","false","fcmp","fdiv","float","fmul","fpext","fptosi","fptoui","fptrunc","frem","fsub","getelementptr inbounds","getelementptr inbounds ([","i","i8","icmp","load","lshr","mul nuw nsw","ne","oge","ogt","ole","olt","or","ret","sdiv","sext","sge","sgt","shl","sitofp","sle","slt","srem","store","sub nuw nsw","switch","to","true","trunc","type","udiv","uge","ugt","uitofp","ule","ult","urem","void","x","x i8 ] c","x i8 ]*","xor","zext","{","|","}"]
+grmLexFilePath = lexFilePath myLexemes
+grmLexContents = lexContents myLexemes
+data Module
+ = Module DefineList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Define
+ = Define Type Lident TVarList StmtList
+ | Declare Type Lident TypeList
+ | TypeD Lident Type
+ | StringD Lident Number Lident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Stmt
+ = LetS Lident Exp
+ | StoreS Atom TVar
+ | CallS TVar AtomList
+ | SwitchS Atom Lident SwitchAltList
+ | ReturnS Atom
+ | LabelS Lident
+ | BrS UAtom Lident Lident
+ | Br0S Lident
+ | TagS Atom
+ | NoOpS
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Exp
+ = CallE TVar AtomList
+ | CastE Cast TVar Type
+ | AllocaE Type
+ | LoadE TVar
+ | AtomE Atom
+ | BinOpE BinOp Type UAtom UAtom
+ | IdxE TVar Atom
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Cast
+ = Bitcast
+ | Sitofp
+ | Uitofp
+ | Fptosi
+ | Fptoui
+ | Trunc
+ | Zext
+ | Sext
+ | Fptrunc
+ | Fpext
+ deriving (Show,Eq,Ord,Data,Typeable)
+data BinOp
+ = Icmp ICond
+ | Fcmp FCond
+ | Add
+ | Fadd
+ | Sub
+ | Fsub
+ | Mul
+ | Fmul
+ | Udiv
+ | Sdiv
+ | Fdiv
+ | Urem
+ | Srem
+ | Frem
+ | Shl
+ | Lshr
+ | And
+ | Or
+ | Xor
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Atom
+ = LitA TLit
+ | VarA TVar
+ deriving (Show,Eq,Ord,Data,Typeable)
+data UAtom
+ = LitUA Lit
+ | VarUA Lident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data ICond
+ = Equ
+ | Neq
+ | Ugt
+ | Sgt
+ | Uge
+ | Sge
+ | Ult
+ | Slt
+ | Ule
+ | Sle
+ deriving (Show,Eq,Ord,Data,Typeable)
+data FCond
+ = Ogt
+ | Oge
+ | Olt
+ | Ole
+ deriving (Show,Eq,Ord,Data,Typeable)
+data SwitchAlt
+ = SwitchAlt TLit Lident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Lit
+ = NmbrL Number
+ | FalseL
+ | TrueL
+ | StringL Number Lident
+ | VoidL
+ deriving (Show,Eq,Ord,Data,Typeable)
+data TVar
+ = TVar Type Lident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data TLit
+ = TLit Type Lit
+ deriving (Show,Eq,Ord,Data,Typeable)
+data FieldT
+ = FieldT Uident Type
+ deriving (Show,Eq,Ord,Data,Typeable)
+data ConC
+ = ConC Uident Type
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Type
+ = PtrT Type
+ | IntT Number
+ | FloatT
+ | DoubleT
+ | VoidT
+ | FunT Type TypeList
+ | VarArgsT
+ | UserT Lident
+ | StructT TypeList
+ | ArrayT Number Type
+ | CharT
+ deriving (Show,Eq,Ord,Data,Typeable)
+type ConCList = [ConC ]
+type FieldTList = [FieldT ]
+type TypeList = [Type ]
+type ExpList = [Exp ]
+type AtomList = [Atom ]
+type TVarList = [TVar ]
+type SwitchAltList = [SwitchAlt ]
+type StmtList = [Stmt ]
+type DefineList = [Define ]
+instance Pretty (Module ) where
+ pretty = ppModule
+ppModule x = case x of
+ Module v1 -> ppDefineList v1
+instance Pretty (Define ) where
+ pretty = ppDefine
+ppDefine x = case x of
+ Define v1 v2 v3 v4 -> text "define" <+> ppType v1 <+> ppLident v2 <+> text "(" <+> ppTVarList v3 <+> text ")" <+> text "{" <+> ppStmtList v4 <+> text "}"
+ Declare v1 v2 v3 -> text "declare" <+> ppType v1 <+> ppLident v2 <+> text "(" <+> ppTypeList v3 <+> text ")"
+ TypeD v1 v2 -> ppLident v1 <+> text "=" <+> text "type" <+> ppType v2
+ StringD v1 v2 v3 -> ppLident v1 <+> text "= private constant [" <+> ppNumber v2 <+> text "x i8 ] c" <> text "\"" <> ppLident v3 <> text "\\00\""
+instance Pretty (Stmt ) where
+ pretty = ppStmt
+ppStmt x = case x of
+ LetS v1 v2 -> ppLident v1 <+> text "=" <+> ppExp v2
+ StoreS v1 v2 -> text "store" <+> ppAtom v1 <> text "," <+> ppTVar v2
+ CallS v1 v2 -> text "call" <+> ppTVar v1 <+> text "(" <+> ppAtomList v2 <+> text ")"
+ SwitchS v1 v2 v3 -> text "switch" <+> ppAtom v1 <> text ", label %" <> ppLident v2 <+> text "[" <+> ppSwitchAltList v3 <+> text "]"
+ ReturnS v1 -> text "ret" <+> ppAtom v1
+ LabelS v1 -> ppLident v1 <> text ":"
+ BrS v1 v2 v3 -> text "br i1" <+> ppUAtom v1 <> text ", label %" <> ppLident v2 <> text ", label %" <> ppLident v3
+ Br0S v1 -> text "br label %" <> ppLident v1
+ TagS v1 -> text "store" <+> ppAtom v1 <> text ","
+ NoOpS -> text ";"
+instance Pretty (Exp ) where
+ pretty = ppExp
+ppExp x = case x of
+ CallE v1 v2 -> text "call" <+> ppTVar v1 <+> text "(" <+> ppAtomList v2 <+> text ")"
+ CastE v1 v2 v3 -> ppCast v1 <+> ppTVar v2 <+> text "to" <+> ppType v3
+ AllocaE v1 -> text "alloca" <+> ppType v1
+ LoadE v1 -> text "load" <+> ppTVar v1
+ AtomE v1 -> ppAtom v1
+ BinOpE v1 v2 v3 v4 -> ppBinOp v1 <+> ppType v2 <+> ppUAtom v3 <> text "," <+> ppUAtom v4
+ IdxE v1 v2 -> text "getelementptr inbounds" <+> ppTVar v1 <> text ", i32 0," <+> ppAtom v2
+instance Pretty (Cast ) where
+ pretty = ppCast
+ppCast x = case x of
+ Bitcast -> text "bitcast"
+ Sitofp -> text "sitofp"
+ Uitofp -> text "uitofp"
+ Fptosi -> text "fptosi"
+ Fptoui -> text "fptoui"
+ Trunc -> text "trunc"
+ Zext -> text "zext"
+ Sext -> text "sext"
+ Fptrunc -> text "fptrunc"
+ Fpext -> text "fpext"
+instance Pretty (BinOp ) where
+ pretty = ppBinOp
+ppBinOp x = case x of
+ Icmp v1 -> text "icmp" <+> ppICond v1
+ Fcmp v1 -> text "fcmp" <+> ppFCond v1
+ Add -> text "add nuw nsw"
+ Fadd -> text "fadd"
+ Sub -> text "sub nuw nsw"
+ Fsub -> text "fsub"
+ Mul -> text "mul nuw nsw"
+ Fmul -> text "fmul"
+ Udiv -> text "udiv"
+ Sdiv -> text "sdiv"
+ Fdiv -> text "fdiv"
+ Urem -> text "urem"
+ Srem -> text "srem"
+ Frem -> text "frem"
+ Shl -> text "shl"
+ Lshr -> text "lshr"
+ And -> text "and"
+ Or -> text "or"
+ Xor -> text "xor"
+instance Pretty (Atom ) where
+ pretty = ppAtom
+ppAtom x = case x of
+ LitA v1 -> ppTLit v1
+ VarA v1 -> ppTVar v1
+instance Pretty (UAtom ) where
+ pretty = ppUAtom
+ppUAtom x = case x of
+ LitUA v1 -> ppLit v1
+ VarUA v1 -> ppLident v1
+instance Pretty (ICond ) where
+ pretty = ppICond
+ppICond x = case x of
+ Equ -> text "eq"
+ Neq -> text "ne"
+ Ugt -> text "ugt"
+ Sgt -> text "sgt"
+ Uge -> text "uge"
+ Sge -> text "sge"
+ Ult -> text "ult"
+ Slt -> text "slt"
+ Ule -> text "ule"
+ Sle -> text "sle"
+instance Pretty (FCond ) where
+ pretty = ppFCond
+ppFCond x = case x of
+ Ogt -> text "ogt"
+ Oge -> text "oge"
+ Olt -> text "olt"
+ Ole -> text "ole"
+instance Pretty (SwitchAlt ) where
+ pretty = ppSwitchAlt
+ppSwitchAlt x = case x of
+ SwitchAlt v1 v2 -> ppTLit v1 <> text ", label %" <> ppLident v2
+instance Pretty (Lit ) where
+ pretty = ppLit
+ppLit x = case x of
+ NmbrL v1 -> ppNumber v1
+ FalseL -> text "false"
+ TrueL -> text "true"
+ StringL v1 v2 -> text "getelementptr inbounds ([" <+> ppNumber v1 <+> text "x i8 ]*" <+> ppLident v2 <> text ", i32 0, i32 0)"
+ VoidL -> Text.PrettyPrint.Leijen.empty
+instance Pretty (TVar ) where
+ pretty = ppTVar
+ppTVar x = case x of
+ TVar v1 v2 -> ppType v1 <+> ppLident v2
+instance Pretty (TLit ) where
+ pretty = ppTLit
+ppTLit x = case x of
+ TLit v1 v2 -> ppType v1 <+> ppLit v2
+instance Pretty (FieldT ) where
+ pretty = ppFieldT
+ppFieldT x = case x of
+ FieldT v1 v2 -> ppUident v1 <+> text "::" <+> ppType v2
+instance Pretty (ConC ) where
+ pretty = ppConC
+ppConC x = case x of
+ ConC v1 v2 -> ppUident v1 <+> ppType v2
+instance Pretty (Type ) where
+ pretty = ppType
+ppType x = case x of
+ PtrT v1 -> ppType v1 <> text "*"
+ IntT v1 -> text "i" <> ppNumber v1
+ FloatT -> text "float"
+ DoubleT -> text "double"
+ VoidT -> text "void"
+ FunT v1 v2 -> ppType v1 <+> text "(" <+> ppTypeList v2 <+> text ")"
+ VarArgsT -> text "..."
+ UserT v1 -> ppLident v1
+ StructT v1 -> text "{" <+> ppTypeList v1 <+> text "}"
+ ArrayT v1 v2 -> text "[" <+> ppNumber v1 <+> text "x" <+> ppType v2 <+> text "]"
+ CharT -> text "i8"
+ppConCList = ppList ppConC Separator "|" Horiz
+ppFieldTList = ppList ppFieldT Separator "," Horiz
+ppTypeList = ppList ppType Separator "," Horiz
+ppExpList = ppList ppExp Separator "," Horiz
+ppAtomList = ppList ppAtom Separator "," Horiz
+ppTVarList = ppList ppTVar Separator "," Horiz
+ppSwitchAltList = ppList ppSwitchAlt Terminator "" Vert
+ppStmtList = ppList ppStmt Terminator "" Vert
+ppDefineList = ppList ppDefine Terminator "" Vert
diff --git a/Language/Pds/Abs.hs b/Language/Pds/Abs.hs
new file mode 100644
--- /dev/null
+++ b/Language/Pds/Abs.hs
@@ -0,0 +1,209 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module Language.Pds.Abs where
+import Control.DeepSeq
+import Data.Generics
+import Grm.Prims
+import Grm.Lex
+import Text.PrettyPrint.Leijen
+myLexemes = ["(",")",",","->","::",";","=","=>","VoidT","\\","as","enum","export","import","in","instance","let","module","newtype","of","record","switch","synonym","tagged","type","unit","{","|","}"]
+grmLexFilePath = lexFilePath myLexemes
+grmLexContents = lexContents myLexemes
+data Module
+ = Module Uident ExportDList ImportDList TypeDList InstDList VarDList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data ExportD
+ = TypeEx Uident
+ | VarEx Lident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data ImportD
+ = ImportD Uident AsSpec
+ deriving (Show,Eq,Ord,Data,Typeable)
+data AsSpec
+ = AsAS Uident
+ | EmptyAS
+ deriving (Show,Eq,Ord,Data,Typeable)
+data TypeD
+ = TypeD Uident VarList TyDecl
+ deriving (Show,Eq,Ord,Data,Typeable)
+data VarD
+ = VarD Lident DeclSym Exp
+ deriving (Show,Eq,Ord,Data,Typeable)
+data InstD
+ = InstD Uident Type
+ deriving (Show,Eq,Ord,Data,Typeable)
+data DeclSym
+ = Macro
+ | Define
+ deriving (Show,Eq,Ord,Data,Typeable)
+data TyDecl
+ = TyRecord FieldTList
+ | TyTagged ConCList
+ | TyEnum EnumCList
+ | TySyn Type
+ | TyNewtype Uident Type
+ | TyUnit Uident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Exp
+ = LetE Lident DeclSym Exp Exp
+ | LamE Lident Exp
+ | SwitchE Exp Default SwitchAltList
+ | AppE Exp Exp
+ | AscribeE Exp Type
+ | VarE Lident
+ | LitE Lit
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Default
+ = DefaultNone
+ | DefaultSome Exp
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Lit
+ = CharL Char
+ | StringL String
+ | NmbrL Number
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Type
+ = TyCxt CxtList Type
+ | TyFun Type Type
+ | TyVoid
+ | TyConstr Uident TypeList
+ | TyVarT Lident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data SwitchAlt
+ = SwitchAlt Exp Exp
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Cxt
+ = Cxt Uident VarList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data ConC
+ = ConC Uident Type
+ deriving (Show,Eq,Ord,Data,Typeable)
+data EnumC
+ = EnumC Uident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data FieldT
+ = FieldT Uident Type
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Var
+ = Var Lident
+ deriving (Show,Eq,Ord,Data,Typeable)
+type ExportDList = [ExportD ]
+type ImportDList = [ImportD ]
+type VarDList = [VarD ]
+type TypeDList = [TypeD ]
+type InstDList = [InstD ]
+type SwitchAltList = [SwitchAlt ]
+type EnumCList = [EnumC ]
+type ConCList = [ConC ]
+type FieldTList = [FieldT ]
+type VarList = [Var ]
+type TypeList = [Type ]
+type CxtList = [Cxt ]
+instance Pretty (Module ) where
+ pretty = ppModule
+ppModule x = case x of
+ Module v1 v2 v3 v4 v5 v6 -> text "module" <+> ppUident v1 <+> text "{" <+> ppExportDList v2 <+> ppImportDList v3 <+> ppTypeDList v4 <+> ppInstDList v5 <+> ppVarDList v6 <+> text "}"
+instance Pretty (ExportD ) where
+ pretty = ppExportD
+ppExportD x = case x of
+ TypeEx v1 -> text "export" <+> ppUident v1
+ VarEx v1 -> text "export" <+> ppLident v1
+instance Pretty (ImportD ) where
+ pretty = ppImportD
+ppImportD x = case x of
+ ImportD v1 v2 -> text "import" <+> ppUident v1 <+> ppAsSpec v2
+instance Pretty (AsSpec ) where
+ pretty = ppAsSpec
+ppAsSpec x = case x of
+ AsAS v1 -> text "as" <+> ppUident v1
+ EmptyAS -> Text.PrettyPrint.Leijen.empty
+instance Pretty (TypeD ) where
+ pretty = ppTypeD
+ppTypeD x = case x of
+ TypeD v1 v2 v3 -> text "type" <+> ppUident v1 <+> ppVarList v2 <+> text "=" <+> ppTyDecl v3
+instance Pretty (VarD ) where
+ pretty = ppVarD
+ppVarD x = case x of
+ VarD v1 v2 v3 -> ppLident v1 <+> ppDeclSym v2 <+> ppExp v3
+instance Pretty (InstD ) where
+ pretty = ppInstD
+ppInstD x = case x of
+ InstD v1 v2 -> text "instance" <+> ppUident v1 <+> ppType v2
+instance Pretty (DeclSym ) where
+ pretty = ppDeclSym
+ppDeclSym x = case x of
+ Macro -> text "=>"
+ Define -> text "="
+instance Pretty (TyDecl ) where
+ pretty = ppTyDecl
+ppTyDecl x = case x of
+ TyRecord v1 -> text "record" <+> text "{" <+> ppFieldTList v1 <+> text "}"
+ TyTagged v1 -> text "tagged" <+> ppConCList v1
+ TyEnum v1 -> text "enum" <+> ppEnumCList v1
+ TySyn v1 -> text "synonym" <+> ppType v1
+ TyNewtype v1 v2 -> text "newtype" <+> ppUident v1 <+> ppType v2
+ TyUnit v1 -> text "unit" <+> ppUident v1
+instance Pretty (Exp ) where
+ pretty = ppExp
+ppExp x = case x of
+ LetE v1 v2 v3 v4 -> text "let" <+> ppLident v1 <+> ppDeclSym v2 <+> ppExp v3 <+> text "in" <+> ppExp v4
+ LamE v1 v2 -> text "\\" <+> ppLident v1 <+> text "->" <+> ppExp v2
+ SwitchE v1 v2 v3 -> text "switch" <+> ppExp v1 <+> text "of" <+> ppDefault v2 <+> text "{" <+> ppSwitchAltList v3 <+> text "}"
+ AppE v1 v2 -> text "(" <+> ppExp v1 <+> ppExp v2 <+> text ")"
+ AscribeE v1 v2 -> text "(" <+> ppExp v1 <+> text "::" <+> ppType v2 <+> text ")"
+ VarE v1 -> ppLident v1
+ LitE v1 -> ppLit v1
+instance Pretty (Default ) where
+ pretty = ppDefault
+ppDefault x = case x of
+ DefaultNone -> Text.PrettyPrint.Leijen.empty
+ DefaultSome v1 -> ppExp v1
+instance Pretty (Lit ) where
+ pretty = ppLit
+ppLit x = case x of
+ CharL v1 -> ppChar v1
+ StringL v1 -> ppString v1
+ NmbrL v1 -> ppNumber v1
+instance Pretty (Type ) where
+ pretty = ppType
+ppType x = case x of
+ TyCxt v1 v2 -> text "{" <+> ppCxtList v1 <+> text "}" <+> text "=>" <+> ppType v2
+ TyFun v1 v2 -> text "(" <+> ppType v1 <+> text "->" <+> ppType v2 <+> text ")"
+ TyVoid -> text "VoidT"
+ TyConstr v1 v2 -> text "(" <+> ppUident v1 <+> ppTypeList v2 <+> text ")"
+ TyVarT v1 -> ppLident v1
+instance Pretty (SwitchAlt ) where
+ pretty = ppSwitchAlt
+ppSwitchAlt x = case x of
+ SwitchAlt v1 v2 -> ppExp v1 <+> text "->" <+> ppExp v2
+instance Pretty (Cxt ) where
+ pretty = ppCxt
+ppCxt x = case x of
+ Cxt v1 v2 -> ppUident v1 <+> ppVarList v2
+instance Pretty (ConC ) where
+ pretty = ppConC
+ppConC x = case x of
+ ConC v1 v2 -> ppUident v1 <+> ppType v2
+instance Pretty (EnumC ) where
+ pretty = ppEnumC
+ppEnumC x = case x of
+ EnumC v1 -> ppUident v1
+instance Pretty (FieldT ) where
+ pretty = ppFieldT
+ppFieldT x = case x of
+ FieldT v1 v2 -> ppUident v1 <+> text "::" <+> ppType v2
+instance Pretty (Var ) where
+ pretty = ppVar
+ppVar x = case x of
+ Var v1 -> ppLident v1
+ppExportDList = ppList ppExportD Terminator ";" Vert
+ppImportDList = ppList ppImportD Terminator ";" Vert
+ppVarDList = ppList ppVarD Terminator ";" Vert
+ppTypeDList = ppList ppTypeD Terminator ";" Vert
+ppInstDList = ppList ppInstD Terminator ";" Vert
+ppSwitchAltList = ppList ppSwitchAlt Terminator ";" Vert
+ppEnumCList = ppList ppEnumC Separator "|" Horiz
+ppConCList = ppList ppConC Separator "|" Horiz
+ppFieldTList = ppList ppFieldT Separator "," Horiz
+ppVarList = ppList ppVar Separator "" Horiz
+ppTypeList = ppList ppType Separator "" Horiz
+ppCxtList = ppList ppCxt Separator "," Horiz
diff --git a/Language/Pec/Abs.hs b/Language/Pec/Abs.hs
--- a/Language/Pec/Abs.hs
+++ b/Language/Pec/Abs.hs
@@ -1,151 +1,512 @@
+{-# LANGUAGE DeriveDataTypeable #-}
module Language.Pec.Abs where
+import Control.DeepSeq
+import Data.Generics
+import Grm.Prims
+import Grm.Lex
+import Text.PrettyPrint.Leijen
+myLexemes = ["#","(",")",",","->",".","..","::",";","<-","=","=>","@","Array","[","\\","]","as","branch","case","do","exports","extern","imports","in","instance","let","module","of","switch","type","where","{","|","}"]
+grmLexFilePath = lexFilePath myLexemes
+grmLexContents = lexContents myLexemes
+data Module a
+ = Module a (Modid a) (ExportDecls a) (ImportDecls a) (TopDeclList a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data ExportDecls a
+ = ExpListD a (ExportList a)
+ | ExpAllD a
+ deriving (Show,Eq,Ord,Data,Typeable)
+data ImportDecls a
+ = ImpListD a (ImportList a)
+ | ImpNoneD a
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Export a
+ = TypeEx a (Con a) (Spec a)
+ | VarEx a (Var a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Import a
+ = Import a (Modid a) (AsSpec a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data AsSpec a
+ = AsAS a (Modid a)
+ | EmptyAS a
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Spec a
+ = Neither a
+ | Decon a
+ | Both a
+ deriving (Show,Eq,Ord,Data,Typeable)
+data TopDecl a
+ = ExternD a (ExtNm a) (Var a) (Type a)
+ | TypeD a (Con a) (VarList a) (TyDecl a)
+ | TypeD0 a (Con a) (VarList a)
+ | AscribeD a (Var a) (Type a)
+ | VarD a (Var a) (DeclSym a) (Exp a)
+ | ProcD a (Var a) (Exp0List a) (DeclSym a) (Exp a)
+ | InstD a (Con a) (Type a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data DeclSym a
+ = Macro a
+ | Define a
+ deriving (Show,Eq,Ord,Data,Typeable)
+data ExtNm a
+ = SomeNm a String
+ | NoneNm a
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Exp a
+ = BlockE a (Exp5List a)
+ | LetS a (Exp4 a) (DeclSym a) (Exp a)
+ | LetE a (Exp4 a) (DeclSym a) (Exp a) (Exp a)
+ | LamE a (Exp0List a) (Exp a)
+ | StoreE a (Exp4 a) (Exp a)
+ | CaseE a (Exp a) (CaseAltList a) (DefaultAlt a)
+ | SwitchE a (Exp a) (SwitchAltList a) (DefaultAlt a)
+ | BranchE a (BranchAltList a) (Exp a)
+ | BinOpE a (Exp3 a) Usym (Exp3 a)
+ | AppE a (Exp3 a) (Exp2 a)
+ | UnOpE a (UnOp a) (Exp1 a)
+ | IdxE a (Exp1 a) (Exp a)
+ | FldE a (Exp1 a) (Field a)
+ | ArrayE a (ExpList a)
+ | RecordE a (FieldDList a)
+ | TupleE a (ExpList a)
+ | AscribeE a (Exp a) (Type a)
+ | CountE a (Count a)
+ | VarE a (Var a)
+ | LitE a (Lit a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+type Exp5 a = Exp a
+type Exp4 a = Exp a
+type Exp3 a = Exp a
+type Exp2 a = Exp a
+type Exp1 a = Exp a
+type Exp0 a = Exp a
+data UnOp a
+ = Load a
+ deriving (Show,Eq,Ord,Data,Typeable)
+data CaseAlt a
+ = CaseAlt a (Con a) (VarList a) (Exp a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data SwitchAlt a
+ = SwitchAlt a (Lit a) (Exp a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data DefaultAlt a
+ = DefaultAlt a (Var a) (Exp a)
+ | DefaultNone a
+ deriving (Show,Eq,Ord,Data,Typeable)
+data BranchAlt a
+ = BranchAlt a (Exp4 a) (Exp a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Cxt a
+ = Cxt a (Con a) (VarList a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Type a
+ = TyCxt a (CxtList a) (Type3 a)
+ | TyFun a (Type2 a) (Type3 a)
+ | TyArray a (Type1 a) (Type1 a)
+ | TyConstr a (Con a) (Type1List a)
+ | TyTuple a (TypeList a)
+ | TyCount a (Count a)
+ | TyVarT a (TyVar a)
+ | TyConstr0 a (Con a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+type Type3 a = Type a
+type Type2 a = Type a
+type Type1 a = Type a
+type Type0 a = Type a
+data TyDecl a
+ = TyRecord a (FieldTList a)
+ | TyTagged a (ConCList a)
+ | TySyn a (Type a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data ConC a
+ = ConC a (Con a) (Type0List a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data FieldT a
+ = FieldT a (Field a) (Type a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Lit a
+ = CharL a Char
+ | StringL a String
+ | NmbrL a Number
+ | EnumL a (Con a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data FieldD a
+ = FieldD a (Field a) (Exp a)
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Count a
+ = Count a Number
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Var a
+ = Var a Lident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Con a
+ = Con a Uident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Modid a
+ = Modid a Uident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Field a
+ = Field a Lident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data TyVar a
+ = VarTV a Lident
+ | CntTV a Lident
+ deriving (Show,Eq,Ord,Data,Typeable)
+type BranchAltList a = [BranchAlt a]
+type CaseAltList a = [CaseAlt a]
+type SwitchAltList a = [SwitchAlt a]
+type TopDeclList a = [TopDecl a]
+type ImportList a = [Import a]
+type Exp5List a = [Exp5 a]
+type ExportList a = [Export a]
+type ConCList a = [ConC a]
+type Exp0List a = [Exp0 a]
+type VarList a = [Var a]
+type ExpList a = [Exp a]
+type FieldDList a = [FieldD a]
+type FieldTList a = [FieldT a]
+type Type0List a = [Type0 a]
+type Type1List a = [Type1 a]
+type TypeList a = [Type3 a]
+type CxtList a = [Cxt a]
+instance HasMeta Module where
+ meta x = case x of
+ Module a _ _ _ _ -> a
+instance HasMeta ExportDecls where
+ meta x = case x of
+ ExpListD a _ -> a
+ ExpAllD a -> a
+instance HasMeta ImportDecls where
+ meta x = case x of
+ ImpListD a _ -> a
+ ImpNoneD a -> a
+instance HasMeta Export where
+ meta x = case x of
+ TypeEx a _ _ -> a
+ VarEx a _ -> a
+instance HasMeta Import where
+ meta x = case x of
+ Import a _ _ -> a
+instance HasMeta AsSpec where
+ meta x = case x of
+ AsAS a _ -> a
+ EmptyAS a -> a
+instance HasMeta Spec where
+ meta x = case x of
+ Neither a -> a
+ Decon a -> a
+ Both a -> a
+instance HasMeta TopDecl where
+ meta x = case x of
+ ExternD a _ _ _ -> a
+ TypeD a _ _ _ -> a
+ TypeD0 a _ _ -> a
+ AscribeD a _ _ -> a
+ VarD a _ _ _ -> a
+ ProcD a _ _ _ _ -> a
+ InstD a _ _ -> a
+instance HasMeta DeclSym where
+ meta x = case x of
+ Macro a -> a
+ Define a -> a
+instance HasMeta ExtNm where
+ meta x = case x of
+ SomeNm a _ -> a
+ NoneNm a -> a
+instance HasMeta Exp where
+ meta x = case x of
+ BlockE a _ -> a
+ LetS a _ _ _ -> a
+ LetE a _ _ _ _ -> a
+ LamE a _ _ -> a
+ StoreE a _ _ -> a
+ CaseE a _ _ _ -> a
+ SwitchE a _ _ _ -> a
+ BranchE a _ _ -> a
+ BinOpE a _ _ _ -> a
+ AppE a _ _ -> a
+ UnOpE a _ _ -> a
+ IdxE a _ _ -> a
+ FldE a _ _ -> a
+ ArrayE a _ -> a
+ RecordE a _ -> a
+ TupleE a _ -> a
+ AscribeE a _ _ -> a
+ CountE a _ -> a
+ VarE a _ -> a
+ LitE a _ -> a
+instance HasMeta UnOp where
+ meta x = case x of
+ Load a -> a
+instance HasMeta CaseAlt where
+ meta x = case x of
+ CaseAlt a _ _ _ -> a
+instance HasMeta SwitchAlt where
+ meta x = case x of
+ SwitchAlt a _ _ -> a
+instance HasMeta DefaultAlt where
+ meta x = case x of
+ DefaultAlt a _ _ -> a
+ DefaultNone a -> a
+instance HasMeta BranchAlt where
+ meta x = case x of
+ BranchAlt a _ _ -> a
+instance HasMeta Cxt where
+ meta x = case x of
+ Cxt a _ _ -> a
+instance HasMeta Type where
+ meta x = case x of
+ TyCxt a _ _ -> a
+ TyFun a _ _ -> a
+ TyArray a _ _ -> a
+ TyConstr a _ _ -> a
+ TyTuple a _ -> a
+ TyCount a _ -> a
+ TyVarT a _ -> a
+ TyConstr0 a _ -> a
+instance HasMeta TyDecl where
+ meta x = case x of
+ TyRecord a _ -> a
+ TyTagged a _ -> a
+ TySyn a _ -> a
+instance HasMeta ConC where
+ meta x = case x of
+ ConC a _ _ -> a
+instance HasMeta FieldT where
+ meta x = case x of
+ FieldT a _ _ -> a
+instance HasMeta Lit where
+ meta x = case x of
+ CharL a _ -> a
+ StringL a _ -> a
+ NmbrL a _ -> a
+ EnumL a _ -> a
+instance HasMeta FieldD where
+ meta x = case x of
+ FieldD a _ _ -> a
+instance HasMeta Count where
+ meta x = case x of
+ Count a _ -> a
+instance HasMeta Var where
+ meta x = case x of
+ Var a _ -> a
+instance HasMeta Con where
+ meta x = case x of
+ Con a _ -> a
+instance HasMeta Modid where
+ meta x = case x of
+ Modid a _ -> a
+instance HasMeta Field where
+ meta x = case x of
+ Field a _ -> a
+instance HasMeta TyVar where
+ meta x = case x of
+ VarTV a _ -> a
+ CntTV a _ -> a
--- Haskell module generated by the BNF converter
-newtype Frac = Frac String deriving (Eq,Ord,Show)
-newtype Uident = Uident String deriving (Eq,Ord,Show)
-newtype Lident = Lident String deriving (Eq,Ord,Show)
-newtype USym = USym String deriving (Eq,Ord,Show)
-newtype Number = Number String deriving (Eq,Ord,Show)
-newtype Count = Count String deriving (Eq,Ord,Show)
-data Module =
- Module Modid ExportDecl [TopDecl]
- deriving (Eq,Ord,Show)
-data ExportDecl =
- ExpAllD
- | ExpListD [Export]
- deriving (Eq,Ord,Show)
-data Export =
- TypeEx Con Spec
- | VarEx Var
- deriving (Eq,Ord,Show)
-data Spec =
- Neither
- | Decon
- | Both
- deriving (Eq,Ord,Show)
-data TopDecl =
- ImportD Modid AsSpec
- | ExternD ExtNm Var Type
- | TypeD Con [TyVar] TyDecl
- | AscribeD Var Type
- | VarD Var Exp
- | ProcD Var [Exp] Exp
- deriving (Eq,Ord,Show)
-data AsSpec =
- AsAS Con
- | EmptyAS
- deriving (Eq,Ord,Show)
-data ExtNm =
- SomeNm String
- | NoneNm
- deriving (Eq,Ord,Show)
-data Exp =
- BlockE [Exp]
- | LetS Exp Exp
- | LetE Exp Exp Exp
- | StoreE Exp Exp
- | CaseE Exp [CaseAlt]
- | BranchE [BranchAlt]
- | BinOpE Exp USym Exp
- | AppE Exp Exp
- | UnOpE UnOp Exp
- | IdxE Exp Exp
- | FldE Exp Field
- | ArrayE [Exp]
- | RecordE [FieldD]
- | TupleE [Exp]
- | AscribeE Exp Type
- | CountE Count
- | VarE Var
- | LitE Lit
- deriving (Eq,Ord,Show)
-data UnOp =
- Load
- deriving (Eq,Ord,Show)
-data CaseAlt =
- CaseAlt CasePat Exp
- deriving (Eq,Ord,Show)
-data CasePat =
- ConP Con Var
- | LitP Lit
- | VarP Var
- deriving (Eq,Ord,Show)
-data BranchAlt =
- BranchAlt BranchPat Exp
- deriving (Eq,Ord,Show)
-data BranchPat =
- BoolBP Exp
- | DefaultBP
- deriving (Eq,Ord,Show)
-data Type =
- TyFun Type Type
- | TyArray Type Type
- | TyConstr Con [Type]
- | TyTuple [Type]
- | TyCount Count
- | TyVarT TyVar
- | TyConstr0 Con
- deriving (Eq,Ord,Show)
-data TyDecl =
- TyRecord [FieldT]
- | TyTagged [ConC]
- | TySyn Type
- deriving (Eq,Ord,Show)
-
-data ConC =
- ConC Con [Type]
- deriving (Eq,Ord,Show)
-
-data FieldT =
- FieldT Field Type
- deriving (Eq,Ord,Show)
-
-data Lit =
- CharL Char
- | StringL String
- | IntL Number
- | FracL Frac
- | EnumL Con
- deriving (Eq,Ord,Show)
-
-data FieldD =
- FieldD Field Exp
- deriving (Eq,Ord,Show)
-
-data Var =
- Var Lident
- deriving (Eq,Ord,Show)
-
-data Con =
- Con Uident
- deriving (Eq,Ord,Show)
-
-data Modid =
- Modid Uident
- deriving (Eq,Ord,Show)
-
-data Field =
- Field Lident
- deriving (Eq,Ord,Show)
-
-data TyVar =
- VarTV Lident
- | CntTV Lident
- deriving (Eq,Ord,Show)
-
+instance Pretty (Module a) where
+ pretty = ppModule
+ppModule x = case x of
+ Module _ v1 v2 v3 v4 -> text "module" <+> ppModid v1 <+> ppExportDecls v2 <+> ppImportDecls v3 <+> text "where" <+> text "{" <+> ppTopDeclList v4 <+> text "}"
+instance Pretty (ExportDecls a) where
+ pretty = ppExportDecls
+ppExportDecls x = case x of
+ ExpListD _ v1 -> text "exports" <+> text "{" <+> ppExportList v1 <+> text "}"
+ ExpAllD _ -> Text.PrettyPrint.Leijen.empty
+instance Pretty (ImportDecls a) where
+ pretty = ppImportDecls
+ppImportDecls x = case x of
+ ImpListD _ v1 -> text "imports" <+> text "{" <+> ppImportList v1 <+> text "}"
+ ImpNoneD _ -> Text.PrettyPrint.Leijen.empty
+instance Pretty (Export a) where
+ pretty = ppExport
+ppExport x = case x of
+ TypeEx _ v1 v2 -> ppCon v1 <+> ppSpec v2
+ VarEx _ v1 -> ppVar v1
+instance Pretty (Import a) where
+ pretty = ppImport
+ppImport x = case x of
+ Import _ v1 v2 -> ppModid v1 <+> ppAsSpec v2
+instance Pretty (AsSpec a) where
+ pretty = ppAsSpec
+ppAsSpec x = case x of
+ AsAS _ v1 -> text "as" <+> ppModid v1
+ EmptyAS _ -> Text.PrettyPrint.Leijen.empty
+instance Pretty (Spec a) where
+ pretty = ppSpec
+ppSpec x = case x of
+ Neither _ -> Text.PrettyPrint.Leijen.empty
+ Decon _ -> text "(" <+> text "." <+> text ")"
+ Both _ -> text "(" <+> text ".." <+> text ")"
+instance Pretty (TopDecl a) where
+ pretty = ppTopDecl
+ppTopDecl x = case x of
+ ExternD _ v1 v2 v3 -> text "extern" <+> ppExtNm v1 <+> ppVar v2 <+> text "::" <+> ppType v3
+ TypeD _ v1 v2 v3 -> text "type" <+> ppCon v1 <+> ppVarList v2 <+> text "=" <+> ppTyDecl v3
+ TypeD0 _ v1 v2 -> text "type" <+> ppCon v1 <+> ppVarList v2
+ AscribeD _ v1 v2 -> ppVar v1 <+> text "::" <+> ppType v2
+ VarD _ v1 v2 v3 -> ppVar v1 <+> ppDeclSym v2 <+> ppExp v3
+ ProcD _ v1 v2 v3 v4 -> ppVar v1 <+> ppExp0List v2 <+> ppDeclSym v3 <+> ppExp v4
+ InstD _ v1 v2 -> text "instance" <+> ppCon v1 <+> ppType v2
+instance Pretty (DeclSym a) where
+ pretty = ppDeclSym
+ppDeclSym x = case x of
+ Macro _ -> text "=>"
+ Define _ -> text "="
+instance Pretty (ExtNm a) where
+ pretty = ppExtNm
+ppExtNm x = case x of
+ SomeNm _ v1 -> ppString v1
+ NoneNm _ -> Text.PrettyPrint.Leijen.empty
+instance Pretty (Exp a) where
+ pretty = ppExp
+ppExp x = case x of
+ BlockE _ v1 -> text "do" <+> text "{" <+> ppExp5List v1 <+> text "}"
+ LetS _ v1 v2 v3 -> ppExp4 v1 <+> ppDeclSym v2 <+> ppExp v3
+ LetE _ v1 v2 v3 v4 -> text "let" <+> ppExp4 v1 <+> ppDeclSym v2 <+> ppExp v3 <+> text "in" <+> ppExp v4
+ LamE _ v1 v2 -> text "\\" <+> ppExp0List v1 <+> text "->" <+> ppExp v2
+ StoreE _ v1 v2 -> ppExp4 v1 <+> text "<-" <+> ppExp v2
+ CaseE _ v1 v2 v3 -> text "case" <+> ppExp v1 <+> text "of" <+> text "{" <+> ppCaseAltList v2 <+> ppDefaultAlt v3 <+> text "}"
+ SwitchE _ v1 v2 v3 -> text "switch" <+> ppExp v1 <+> text "of" <+> text "{" <+> ppSwitchAltList v2 <+> ppDefaultAlt v3 <+> text "}"
+ BranchE _ v1 v2 -> text "branch" <+> text "{" <+> ppBranchAltList v1 <+> text "|" <+> ppExp v2 <+> text ";" <+> text "}"
+ BinOpE _ v1 v2 v3 -> ppExp3 v1 <+> ppUsym v2 <+> ppExp3 v3
+ AppE _ v1 v2 -> ppExp3 v1 <+> ppExp2 v2
+ UnOpE _ v1 v2 -> ppUnOp v1 <+> ppExp1 v2
+ IdxE _ v1 v2 -> ppExp1 v1 <+> text "[" <+> ppExp v2 <+> text "]"
+ FldE _ v1 v2 -> ppExp1 v1 <+> text "." <+> ppField v2
+ ArrayE _ v1 -> text "Array" <+> text "[" <+> ppExpList v1 <+> text "]"
+ RecordE _ v1 -> text "{" <+> ppFieldDList v1 <+> text "}"
+ TupleE _ v1 -> text "(" <+> ppExpList v1 <+> text ")"
+ AscribeE _ v1 v2 -> text "(" <+> ppExp v1 <+> text "::" <+> ppType v2 <+> text ")"
+ CountE _ v1 -> ppCount v1
+ VarE _ v1 -> ppVar v1
+ LitE _ v1 -> ppLit v1
+ppExp5 = ppExp
+ppExp4 = ppExp
+ppExp3 = ppExp
+ppExp2 = ppExp
+ppExp1 = ppExp
+ppExp0 = ppExp
+instance Pretty (UnOp a) where
+ pretty = ppUnOp
+ppUnOp x = case x of
+ Load _ -> text "@"
+instance Pretty (CaseAlt a) where
+ pretty = ppCaseAlt
+ppCaseAlt x = case x of
+ CaseAlt _ v1 v2 v3 -> ppCon v1 <+> ppVarList v2 <+> text "->" <+> ppExp v3
+instance Pretty (SwitchAlt a) where
+ pretty = ppSwitchAlt
+ppSwitchAlt x = case x of
+ SwitchAlt _ v1 v2 -> ppLit v1 <+> text "->" <+> ppExp v2
+instance Pretty (DefaultAlt a) where
+ pretty = ppDefaultAlt
+ppDefaultAlt x = case x of
+ DefaultAlt _ v1 v2 -> ppVar v1 <+> text "->" <+> ppExp v2 <+> text ";"
+ DefaultNone _ -> Text.PrettyPrint.Leijen.empty
+instance Pretty (BranchAlt a) where
+ pretty = ppBranchAlt
+ppBranchAlt x = case x of
+ BranchAlt _ v1 v2 -> ppExp4 v1 <+> text "->" <+> ppExp v2
+instance Pretty (Cxt a) where
+ pretty = ppCxt
+ppCxt x = case x of
+ Cxt _ v1 v2 -> ppCon v1 <+> ppVarList v2
+instance Pretty (Type a) where
+ pretty = ppType
+ppType x = case x of
+ TyCxt _ v1 v2 -> text "{" <+> ppCxtList v1 <+> text "}" <+> text "=>" <+> ppType3 v2
+ TyFun _ v1 v2 -> ppType2 v1 <+> text "->" <+> ppType3 v2
+ TyArray _ v1 v2 -> text "Array" <+> ppType1 v1 <+> ppType1 v2
+ TyConstr _ v1 v2 -> ppCon v1 <+> ppType1List v2
+ TyTuple _ v1 -> text "(" <+> ppTypeList v1 <+> text ")"
+ TyCount _ v1 -> ppCount v1
+ TyVarT _ v1 -> ppTyVar v1
+ TyConstr0 _ v1 -> ppCon v1
+ppType3 = ppType
+ppType2 = ppType
+ppType1 = ppType
+ppType0 = ppType
+instance Pretty (TyDecl a) where
+ pretty = ppTyDecl
+ppTyDecl x = case x of
+ TyRecord _ v1 -> text "{" <+> ppFieldTList v1 <+> text "}"
+ TyTagged _ v1 -> text "|" <+> ppConCList v1
+ TySyn _ v1 -> ppType v1
+instance Pretty (ConC a) where
+ pretty = ppConC
+ppConC x = case x of
+ ConC _ v1 v2 -> ppCon v1 <+> ppType0List v2
+instance Pretty (FieldT a) where
+ pretty = ppFieldT
+ppFieldT x = case x of
+ FieldT _ v1 v2 -> ppField v1 <+> text "::" <+> ppType v2
+instance Pretty (Lit a) where
+ pretty = ppLit
+ppLit x = case x of
+ CharL _ v1 -> ppChar v1
+ StringL _ v1 -> ppString v1
+ NmbrL _ v1 -> ppNumber v1
+ EnumL _ v1 -> ppCon v1
+instance Pretty (FieldD a) where
+ pretty = ppFieldD
+ppFieldD x = case x of
+ FieldD _ v1 v2 -> ppField v1 <+> text "=" <+> ppExp v2
+instance Pretty (Count a) where
+ pretty = ppCount
+ppCount x = case x of
+ Count _ v1 -> text "#" <> ppNumber v1
+instance Pretty (Var a) where
+ pretty = ppVar
+ppVar x = case x of
+ Var _ v1 -> ppLident v1
+instance Pretty (Con a) where
+ pretty = ppCon
+ppCon x = case x of
+ Con _ v1 -> ppUident v1
+instance Pretty (Modid a) where
+ pretty = ppModid
+ppModid x = case x of
+ Modid _ v1 -> ppUident v1
+instance Pretty (Field a) where
+ pretty = ppField
+ppField x = case x of
+ Field _ v1 -> ppLident v1
+instance Pretty (TyVar a) where
+ pretty = ppTyVar
+ppTyVar x = case x of
+ VarTV _ v1 -> ppLident v1
+ CntTV _ v1 -> text "#" <+> ppLident v1
+ppBranchAltList = ppList ppBranchAlt Terminator ";" Vert
+ppCaseAltList = ppList ppCaseAlt Terminator ";" Vert
+ppSwitchAltList = ppList ppSwitchAlt Terminator ";" Vert
+ppTopDeclList = ppList ppTopDecl Terminator ";" Vert
+ppImportList = ppList ppImport Terminator ";" Vert
+ppExp5List = ppList ppExp5 Terminator ";" Vert
+ppExportList = ppList ppExport Terminator ";" Vert
+ppConCList = ppList ppConC Separator "|" Horiz
+ppExp0List = ppList ppExp0 Separator "" Horiz
+ppVarList = ppList ppVar Separator "" Horiz
+ppExpList = ppList ppExp Separator "," Horiz
+ppFieldDList = ppList ppFieldD Separator "," Horiz
+ppFieldTList = ppList ppFieldT Separator "," Horiz
+ppType0List = ppList ppType0 Separator "" Horiz
+ppType1List = ppList ppType1 Separator "" Horiz
+ppTypeList = ppList ppType3 Separator "," Horiz
+ppCxtList = ppList ppCxt Separator "," Horiz
diff --git a/Language/Pec/Doc.html b/Language/Pec/Doc.html
deleted file mode 100644
--- a/Language/Pec/Doc.html
+++ /dev/null
@@ -1,695 +0,0 @@
-
-
-
-
-The Language Pec
-
-
-The Language Pec
-BNF Converter
-
-
-
-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 Pec
-
-Literals
-
-
-String literals String have the form
-"x", where x is any sequence of any characters
-except " unless preceded by \.
-
-
-Character literals Char have the form
-'c', where c is any single character.
-
-
-Frac literals are recognized by the regular expression
-`'-'? digit+ '.' digit+ ('e' '-'? digit+)?`
-
-
-Uident literals are recognized by the regular expression
-`upper (letter | digit | '_')*`
-
-
-Lident literals are recognized by the regular expression
-`(lower | '_') (letter | digit | '_')*`
-
-
-USym literals are recognized by the regular expression
-`('!' | '#' | '$' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '\' | '^' | '|' | '~')+`
-
-
-Number literals are recognized by the regular expression
-`'-'? digit+`
-
-
-Count literals are recognized by the regular expression
-`'#' digit+`
-
-
-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 Pec are the following:
-
-
-
-
-Array |
-all |
-as |
-branch |
-
-
-case |
-do |
-exports |
-extern |
-
-
-import |
-in |
-let |
-module |
-
-
-of |
-type |
-where |
-
-
-
-
-The symbols used in Pec are the following:
-
-
-
-
-| { |
-} |
-( |
-) |
-
-
-| . |
-.. |
-:: |
-= |
-
-
-| <- |
-[ |
-] |
-@ |
-
-
-| -> |
-| |
-# |
-, |
-
-
-| ; |
- |
- |
-
-
-
-Comments
-
-
-Single-line comments begin with //.Multiple-line comments are enclosed with /* and */.
-
-
-The syntactic structure of Pec
-
-
-Non-terminals are enclosed between < and >.
-The symbols -> (production), | (union)
-and eps (empty rule) belong to the BNF notation.
-All other symbols are terminals.
-
-
-
-
-| Module |
--> |
-module Modid exports ExportDecl where { [TopDecl] } |
-
-
-| ExportDecl |
--> |
-all |
-
-
- |
-| |
-( [Export] ) |
-
-
-| Export |
--> |
-Con Spec |
-
-
- |
-| |
-Var |
-
-
-| Spec |
--> |
-eps |
-
-
- |
-| |
-( . ) |
-
-
- |
-| |
-( .. ) |
-
-
-| TopDecl |
--> |
-import Modid AsSpec |
-
-
- |
-| |
-extern ExtNm Var :: Type |
-
-
- |
-| |
-type Con [TyVar] = TyDecl |
-
-
- |
-| |
-Var :: Type |
-
-
- |
-| |
-Var = Exp |
-
-
- |
-| |
-Var [Exp0] = Exp |
-
-
-| AsSpec |
--> |
-as Con |
-
-
- |
-| |
-eps |
-
-
-| ExtNm |
--> |
-String |
-
-
- |
-| |
-eps |
-
-
-| Exp |
--> |
-do { [Exp5] } |
-
-
- |
-| |
-Exp5 |
-
-
-| Exp5 |
--> |
-Exp4 = Exp |
-
-
- |
-| |
-let Exp4 = Exp in Exp |
-
-
- |
-| |
-Exp4 <- Exp |
-
-
- |
-| |
-case Exp of { [CaseAlt] } |
-
-
- |
-| |
-branch of { [BranchAlt] } |
-
-
- |
-| |
-Exp4 |
-
-
-| Exp4 |
--> |
-Exp3 USym Exp3 |
-
-
- |
-| |
-Exp3 |
-
-
-| Exp3 |
--> |
-Exp3 Exp2 |
-
-
- |
-| |
-Exp2 |
-
-
-| Exp2 |
--> |
-UnOp Exp1 |
-
-
- |
-| |
-Exp1 |
-
-
-| Exp1 |
--> |
-Exp1 [ Exp ] |
-
-
- |
-| |
-Exp1 . Field |
-
-
- |
-| |
-Exp0 |
-
-
-| Exp0 |
--> |
-Array [ [Exp] ] |
-
-
- |
-| |
-{ [FieldD] } |
-
-
- |
-| |
-( [Exp] ) |
-
-
- |
-| |
-( Exp :: Type ) |
-
-
- |
-| |
-Count |
-
-
- |
-| |
-Var |
-
-
- |
-| |
-Lit |
-
-
-| UnOp |
--> |
-@ |
-
-
-| CaseAlt |
--> |
-CasePat -> Exp |
-
-
-| CasePat |
--> |
-Con Var |
-
-
- |
-| |
-Lit |
-
-
- |
-| |
-Var |
-
-
-| BranchAlt |
--> |
-| BranchPat -> Exp |
-
-
-| BranchPat |
--> |
-Exp4 |
-
-
- |
-| |
-eps |
-
-
-| Type |
--> |
-Type2 -> Type |
-
-
- |
-| |
-Type2 |
-
-
-| Type2 |
--> |
-Array Type1 Type1 |
-
-
- |
-| |
-Con [Type1] |
-
-
- |
-| |
-Type1 |
-
-
-| Type1 |
--> |
-Type0 |
-
-
-| Type0 |
--> |
-( [Type] ) |
-
-
- |
-| |
-Count |
-
-
- |
-| |
-TyVar |
-
-
- |
-| |
-Con |
-
-
-| TyDecl |
--> |
-{ [FieldT] } |
-
-
- |
-| |
-| [ConC] |
-
-
- |
-| |
-Type |
-
-
-| ConC |
--> |
-Con [Type0] |
-
-
-| FieldT |
--> |
-Field :: Type |
-
-
-| Lit |
--> |
-Char |
-
-
- |
-| |
-String |
-
-
- |
-| |
-Number |
-
-
- |
-| |
-Frac |
-
-
- |
-| |
-Con |
-
-
-| FieldD |
--> |
-Field = Exp |
-
-
-| Var |
--> |
-Lident |
-
-
-| Con |
--> |
-Uident |
-
-
-| Modid |
--> |
-Uident |
-
-
-| Field |
--> |
-Lident |
-
-
-| TyVar |
--> |
-Lident |
-
-
- |
-| |
-# Lident |
-
-
-| [Exp] |
--> |
-eps |
-
-
- |
-| |
-Exp |
-
-
- |
-| |
-Exp , [Exp] |
-
-
-| [FieldT] |
--> |
-eps |
-
-
- |
-| |
-FieldT |
-
-
- |
-| |
-FieldT , [FieldT] |
-
-
-| [TyVar] |
--> |
-eps |
-
-
- |
-| |
-TyVar [TyVar] |
-
-
-| [Type] |
--> |
-eps |
-
-
- |
-| |
-Type |
-
-
- |
-| |
-Type , [Type] |
-
-
-| [Export] |
--> |
-eps |
-
-
- |
-| |
-Export |
-
-
- |
-| |
-Export , [Export] |
-
-
-| [Type0] |
--> |
-eps |
-
-
- |
-| |
-Type0 [Type0] |
-
-
-| [ConC] |
--> |
-ConC |
-
-
- |
-| |
-ConC | [ConC] |
-
-
-| [Exp0] |
--> |
-Exp0 |
-
-
- |
-| |
-Exp0 [Exp0] |
-
-
-| [FieldD] |
--> |
-FieldD |
-
-
- |
-| |
-FieldD , [FieldD] |
-
-
-| [Type1] |
--> |
-Type1 |
-
-
- |
-| |
-Type1 [Type1] |
-
-
-| [TopDecl] |
--> |
-eps |
-
-
- |
-| |
-TopDecl |
-
-
- |
-| |
-TopDecl ; [TopDecl] |
-
-
-| [CaseAlt] |
--> |
-CaseAlt |
-
-
- |
-| |
-CaseAlt ; [CaseAlt] |
-
-
-| [BranchAlt] |
--> |
-BranchAlt |
-
-
- |
-| |
-BranchAlt ; [BranchAlt] |
-
-
-| [Exp5] |
--> |
-Exp5 |
-
-
- |
-| |
-Exp5 ; [Exp5] |
-
-
-
-
-
-
diff --git a/Language/Pec/ErrM.hs b/Language/Pec/ErrM.hs
deleted file mode 100644
--- a/Language/Pec/ErrM.hs
+++ /dev/null
@@ -1,26 +0,0 @@
--- BNF Converter: Error Monad
--- Copyright (C) 2004 Author: Aarne Ranta
-
--- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
-module Language.Pec.ErrM where
-
--- the Error monad: like Maybe type with error msgs
-
-import Control.Monad (MonadPlus(..), liftM)
-
-data Err a = Ok a | Bad String
- deriving (Read, Show, Eq, Ord)
-
-instance Monad Err where
- return = Ok
- fail = Bad
- Ok a >>= f = f a
- Bad s >>= f = Bad s
-
-instance Functor Err where
- fmap = liftM
-
-instance MonadPlus Err where
- mzero = Bad "Err.mzero"
- mplus (Bad _) y = y
- mplus x _ = x
diff --git a/Language/Pec/Layout.hs b/Language/Pec/Layout.hs
deleted file mode 100644
--- a/Language/Pec/Layout.hs
+++ /dev/null
@@ -1,262 +0,0 @@
-module Language.Pec.Layout where
-
-import Language.Pec.Lex
-
-
-import Data.Maybe (isNothing, fromJust)
-
--- Generated by the BNF Converter
-
--- local parameters
-
-topLayout = False
-layoutWords = ["where","do","of"]
-layoutStopWords = []
-
--- layout separators
-
-layoutOpen = "{"
-layoutClose = "}"
-layoutSep = ";"
-
--- | Replace layout syntax with explicit layout tokens.
-resolveLayout :: Bool -- ^ Whether to use top-level layout.
- -> [Token] -> [Token]
-resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]
- where
- -- Do top-level layout if the function parameter and the grammar say so.
- tl = tp && topLayout
-
- res :: Maybe Token -- ^ The previous token, if any.
- -> [Block] -- ^ A stack of layout blocks.
- -> [Token] -> [Token]
-
- -- The stack should never be empty.
- res _ [] ts = error $ "Layout error: stack empty. Tokens: " ++ show ts
-
- res _ st (t0:ts)
- -- We found an open brace in the input,
- -- put an explicit layout block on the stack.
- -- This is done even if there was no layout word,
- -- to keep opening and closing braces.
- | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts
-
- res _ st (t0:ts)
- -- Start a new layout block if the first token is a layout word
- | isLayout t0 =
- case ts of
- -- Explicit layout, just move on. The case above
- -- will push an explicit layout block.
- t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts
- -- at end of file, the start column doesn't matter
- _ -> let col = if null ts then column t0 else column (head ts)
- -- insert an open brace after the layout word
- b:ts' = addToken (nextPos t0) layoutOpen ts
- -- save the start column
- st' = Implicit col:st
- in moveAlong st' [t0,b] ts'
-
- -- If we encounter a closing brace, exit the first explicit layout block.
- | isLayoutClose t0 =
- let st' = drop 1 (dropWhile isImplicit st)
- in if null st'
- then error $ "Layout error: Found " ++ layoutClose ++ " at ("
- ++ show (line t0) ++ "," ++ show (column t0)
- ++ ") without an explicit layout block."
- else moveAlong st' [t0] ts
-
- -- We are in an implicit layout block
- res pt st@(Implicit n:ns) (t0:ts)
-
- -- End of implicit block by a layout stop word
- | isStop t0 =
- -- Exit the current block and all implicit blocks
- -- more indented than the current token
- let (ebs,ns') = span (`moreIndent` column t0) ns
- moreIndent (Implicit x) y = x > y
- moreIndent Explicit _ = False
- -- the number of blocks exited
- b = 1 + length ebs
- bs = replicate b layoutClose
- -- Insert closing braces after the previous token.
- (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)
- in moveAlong ns' ts1 ts2
-
- -- End of an implicit layout block
- | newLine && column t0 < n =
- -- Insert a closing brace after the previous token.
- let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)
- -- Repeat, with the current block removed from the stack
- in moveAlong ns [b] (t0':ts')
-
- -- Encounted a new line in an implicit layout block.
- | newLine && column t0 == n =
- -- Insert a semicolon after the previous token.
- -- unless we are the beginning of the file,
- -- or the previous token is a semicolon or open brace.
- if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt)
- then moveAlong st [t0] ts
- else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts)
- in moveAlong st [b,t0'] ts'
- where newLine = case pt of
- Nothing -> True
- Just t -> line t /= line t0
-
- -- Nothing to see here, move along.
- res _ st (t:ts) = moveAlong st [t] ts
-
- -- At EOF: skip explicit blocks.
- res (Just t) (Explicit:bs) [] | null bs = []
- | otherwise = res (Just t) bs []
-
- -- If we are using top-level layout, insert a semicolon after
- -- the last token, if there isn't one already
- res (Just t) [Implicit n] []
- | isTokenIn [layoutSep] t = []
- | otherwise = addToken (nextPos t) layoutSep []
-
- -- At EOF in an implicit, non-top-level block: close the block
- res (Just t) (Implicit n:bs) [] =
- let c = addToken (nextPos t) layoutClose []
- in moveAlong bs c []
-
- -- This should only happen if the input is empty.
- res Nothing st [] = []
-
- -- | Move on to the next token.
- moveAlong :: [Block] -- ^ The layout stack.
- -> [Token] -- ^ Any tokens just processed.
- -> [Token] -- ^ the rest of the tokens.
- -> [Token]
- moveAlong st [] ts = error $ "Layout error: moveAlong got [] as old tokens"
- moveAlong st ot ts = ot ++ res (Just $ last ot) st ts
-
-data Block = Implicit Int -- ^ An implicit layout block with its start column.
- | Explicit
- deriving Show
-
-type Position = Posn
-
--- | Check if s block is implicit.
-isImplicit :: Block -> Bool
-isImplicit (Implicit _) = True
-isImplicit _ = False
-
--- | Insert a number of tokens at the begninning of a list of tokens.
-addTokens :: Position -- ^ Position of the first new token.
- -> [String] -- ^ Token symbols.
- -> [Token] -- ^ The rest of the tokens. These will have their
- -- positions updated to make room for the new tokens .
- -> [Token]
-addTokens p ss ts = foldr (addToken p) ts ss
-
--- | Insert a new symbol token at the begninning of a list of tokens.
-addToken :: Position -- ^ Position of the new token.
- -> String -- ^ Symbol in the new token.
- -> [Token] -- ^ The rest of the tokens. These will have their
- -- positions updated to make room for the new token.
- -> [Token]
-addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts
-
--- | Get the position immediately to the right of the given token.
--- If no token is given, gets the first position in the file.
-afterPrev :: Maybe Token -> Position
-afterPrev = maybe (Pn 0 1 1) nextPos
-
--- | Get the position immediately to the right of the given token.
-nextPos :: Token -> Position
-nextPos t = Pn (g + s) l (c + s + 1)
- where Pn g l c = position t
- s = tokenLength t
-
--- | Add to the global and column positions of a token.
--- The column position is only changed if the token is on
--- the same line as the given position.
-incrGlobal :: Position -- ^ If the token is on the same line
- -- as this position, update the column position.
- -> Int -- ^ Number of characters to add to the position.
- -> Token -> Token
-incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) =
- if l /= l0 then PT (Pn (g + i) l c) t
- else PT (Pn (g + i) l (c + i)) t
-incrGlobal _ _ p = error $ "cannot add token at " ++ show p
-
--- | Create a symbol token.
-sToken :: Position -> String -> Token
-sToken p s = PT p (TS s i)
- where
- i = case s of
- "#" -> 1
- "(" -> 2
- ")" -> 3
- "," -> 4
- "->" -> 5
- "." -> 6
- ".." -> 7
- "::" -> 8
- ";" -> 9
- "<-" -> 10
- "=" -> 11
- "@" -> 12
- "Array" -> 13
- "[" -> 14
- "]" -> 15
- "all" -> 16
- "as" -> 17
- "branch" -> 18
- "case" -> 19
- "do" -> 20
- "exports" -> 21
- "extern" -> 22
- "import" -> 23
- "in" -> 24
- "let" -> 25
- "module" -> 26
- "of" -> 27
- "type" -> 28
- "where" -> 29
- "{" -> 30
- "|" -> 31
- "}" -> 32
- _ -> error $ "not a reserved word: " ++ show s
-
--- | Get the position of a token.
-position :: Token -> Position
-position t = case t of
- PT p _ -> p
- Err p -> p
-
--- | Get the line number of a token.
-line :: Token -> Int
-line t = case position t of Pn _ l _ -> l
-
--- | Get the column number of a token.
-column :: Token -> Int
-column t = case position t of Pn _ _ c -> c
-
--- | Check if a token is one of the given symbols.
-isTokenIn :: [String] -> Token -> Bool
-isTokenIn ts t = case t of
- PT _ (TS r _) | elem r ts -> True
- _ -> False
-
--- | Check if a word is a layout start token.
-isLayout :: Token -> Bool
-isLayout = isTokenIn layoutWords
-
--- | Check if a token is a layout stop token.
-isStop :: Token -> Bool
-isStop = isTokenIn layoutStopWords
-
--- | Check if a token is the layout open token.
-isLayoutOpen :: Token -> Bool
-isLayoutOpen = isTokenIn [layoutOpen]
-
--- | Check if a token is the layout close token.
-isLayoutClose :: Token -> Bool
-isLayoutClose = isTokenIn [layoutClose]
-
--- | Get the number of characters in the token.
-tokenLength :: Token -> Int
-tokenLength t = length $ prToken t
-
diff --git a/Language/Pec/Lex.x b/Language/Pec/Lex.x
deleted file mode 100644
--- a/Language/Pec/Lex.x
+++ /dev/null
@@ -1,156 +0,0 @@
--- -*- haskell -*-
--- This Alex file was machine-generated by the BNF converter
-{
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
-module Language.Pec.Lex where
-
-
-
-}
-
-
-$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
-$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
-$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
-$d = [0-9] -- digit
-$i = [$l $d _ '] -- identifier character
-$u = [\0-\255] -- universal: any character
-
-@rsyms = -- symbols and non-identifier-like reserved words
- \{ | \} | \( | \) | \. | \. \. | \: \: | \= | \< \- | \[ | \] | \@ | \- \> | \| | \# | \, | \;
-
-:-
-"//" [.]* ; -- Toss single line comments
-"/*" ([$u # \*] | \* [$u # \/])* ("*")+ "/" ;
-
-$white+ ;
-@rsyms { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
-\- ? $d + \. $d + (e \- ? $d +)? { tok (\p s -> PT p (eitherResIdent (T_Frac . share) s)) }
-$c ($l | $d | \_)* { tok (\p s -> PT p (eitherResIdent (T_Uident . share) s)) }
-($s | \_)($l | $d | \_)* { tok (\p s -> PT p (eitherResIdent (T_Lident . share) s)) }
-(\! | \# | \$ | \% | \& | \* | \+ | \- | \. | \/ | \: | \< | \= | \> | \? | \@ | \\ | \^ | \| | \~)+ { tok (\p s -> PT p (eitherResIdent (T_USym . share) s)) }
-\- ? $d + { tok (\p s -> PT p (eitherResIdent (T_Number . share) s)) }
-\# $d + { tok (\p s -> PT p (eitherResIdent (T_Count . share) s)) }
-
-$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
-\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
-\' ($u # [\' \\] | \\ [\\ \' n t]) \' { tok (\p s -> PT p (TC $ share s)) }
-
-
-
-{
-
-tok f p s = f p s
-
-share :: String -> String
-share = id
-
-data Tok =
- TS !String !Int -- reserved words and symbols
- | TL !String -- string literals
- | TI !String -- integer literals
- | TV !String -- identifiers
- | TD !String -- double precision float literals
- | TC !String -- character literals
- | T_Frac !String
- | T_Uident !String
- | T_Lident !String
- | T_USym !String
- | T_Number !String
- | T_Count !String
-
- deriving (Eq,Show,Ord)
-
-data Token =
- PT Posn Tok
- | Err Posn
- deriving (Eq,Show,Ord)
-
-tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
-tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
-tokenPos _ = "end of file"
-
-posLineCol (Pn _ l c) = (l,c)
-mkPosToken t@(PT p _) = (posLineCol p, prToken t)
-
-prToken t = case t of
- PT _ (TS s _) -> s
- PT _ (TL s) -> s
- PT _ (TI s) -> s
- PT _ (TV s) -> s
- PT _ (TD s) -> s
- PT _ (TC s) -> s
- PT _ (T_Frac s) -> s
- PT _ (T_Uident s) -> s
- PT _ (T_Lident s) -> s
- PT _ (T_USym s) -> s
- PT _ (T_Number s) -> s
- PT _ (T_Count s) -> s
-
-
-data BTree = N | B String Tok BTree BTree deriving (Show)
-
-eitherResIdent :: (String -> Tok) -> String -> Tok
-eitherResIdent tv s = treeFind resWords
- where
- treeFind N = tv s
- treeFind (B a t left right) | s < a = treeFind left
- | s > a = treeFind right
- | s == a = t
-
-resWords = b "as" 17 (b ";" 9 (b "->" 5 (b ")" 3 (b "(" 2 (b "#" 1 N N) N) (b "," 4 N N)) (b ".." 7 (b "." 6 N N) (b "::" 8 N N))) (b "Array" 13 (b "=" 11 (b "<-" 10 N N) (b "@" 12 N N)) (b "]" 15 (b "[" 14 N N) (b "all" 16 N N)))) (b "let" 25 (b "exports" 21 (b "case" 19 (b "branch" 18 N N) (b "do" 20 N N)) (b "import" 23 (b "extern" 22 N N) (b "in" 24 N N))) (b "where" 29 (b "of" 27 (b "module" 26 N N) (b "type" 28 N N)) (b "|" 31 (b "{" 30 N N) (b "}" 32 N N))))
- where b s n = let bs = id s
- in B bs (TS bs n)
-
-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
- '"':[] -> []
- 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 AlexInput = (Posn, -- current position,
- Char, -- previous 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')
-
-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
-alexGetChar (p, _, s) =
- case s of
- [] -> Nothing
- (c:s) ->
- let p' = alexMove p c
- in p' `seq` Just (c, (p', c, s))
-
-alexInputPrevChar :: AlexInput -> Char
-alexInputPrevChar (p, c, s) = c
-}
diff --git a/Language/Pec/Par.hs b/Language/Pec/Par.hs
deleted file mode 100644
--- a/Language/Pec/Par.hs
+++ /dev/null
@@ -1,3137 +0,0 @@
-{-# OPTIONS_GHC -w #-}
-{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
-module Language.Pec.Par where
-import Language.Pec.Abs
-import Language.Pec.Lex
-import Language.Pec.ErrM
-
--- parser produced by Happy Version 1.18.6
-
-data HappyAbsSyn
- = HappyTerminal (Token)
- | HappyErrorToken Int
- | HappyAbsSyn4 (String)
- | HappyAbsSyn5 (Char)
- | HappyAbsSyn6 (Frac)
- | HappyAbsSyn7 (Uident)
- | HappyAbsSyn8 (Lident)
- | HappyAbsSyn9 (USym)
- | HappyAbsSyn10 (Number)
- | HappyAbsSyn11 (Count)
- | HappyAbsSyn12 (Module)
- | HappyAbsSyn13 (ExportDecl)
- | HappyAbsSyn14 (Export)
- | HappyAbsSyn15 (Spec)
- | HappyAbsSyn16 (TopDecl)
- | HappyAbsSyn17 (AsSpec)
- | HappyAbsSyn18 (ExtNm)
- | HappyAbsSyn19 (Exp)
- | HappyAbsSyn26 (UnOp)
- | HappyAbsSyn27 (CaseAlt)
- | HappyAbsSyn28 (CasePat)
- | HappyAbsSyn29 (BranchAlt)
- | HappyAbsSyn30 (BranchPat)
- | HappyAbsSyn31 (Type)
- | HappyAbsSyn35 (TyDecl)
- | HappyAbsSyn36 (ConC)
- | HappyAbsSyn37 (FieldT)
- | HappyAbsSyn38 (Lit)
- | HappyAbsSyn39 (FieldD)
- | HappyAbsSyn40 (Var)
- | HappyAbsSyn41 (Con)
- | HappyAbsSyn42 (Modid)
- | HappyAbsSyn43 (Field)
- | HappyAbsSyn44 (TyVar)
- | HappyAbsSyn45 ([Exp])
- | HappyAbsSyn46 ([FieldT])
- | HappyAbsSyn47 ([TyVar])
- | HappyAbsSyn48 ([Type])
- | HappyAbsSyn49 ([Export])
- | HappyAbsSyn51 ([ConC])
- | HappyAbsSyn53 ([FieldD])
- | HappyAbsSyn55 ([TopDecl])
- | HappyAbsSyn56 ([CaseAlt])
- | HappyAbsSyn57 ([BranchAlt])
-
-{- 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 =
- 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,
- action_92,
- action_93,
- action_94,
- action_95,
- action_96,
- action_97,
- action_98,
- action_99,
- action_100,
- action_101,
- action_102,
- action_103,
- action_104,
- action_105,
- action_106,
- action_107,
- action_108,
- action_109,
- action_110,
- action_111,
- action_112,
- action_113,
- action_114,
- action_115,
- action_116,
- action_117,
- action_118,
- action_119,
- action_120,
- action_121,
- action_122,
- action_123,
- action_124,
- action_125,
- action_126,
- action_127,
- action_128,
- action_129,
- action_130,
- action_131,
- action_132,
- action_133,
- action_134,
- action_135,
- action_136,
- action_137,
- action_138,
- action_139,
- action_140,
- action_141,
- action_142,
- action_143,
- action_144,
- action_145,
- action_146,
- action_147,
- action_148,
- action_149,
- action_150,
- action_151,
- action_152,
- action_153,
- action_154,
- action_155,
- action_156,
- action_157,
- action_158,
- action_159,
- action_160,
- action_161,
- action_162,
- action_163,
- action_164,
- action_165,
- action_166,
- action_167,
- action_168,
- action_169,
- action_170,
- action_171,
- action_172,
- action_173,
- action_174,
- action_175,
- action_176,
- action_177,
- action_178,
- action_179,
- action_180,
- action_181,
- action_182,
- action_183,
- action_184,
- action_185,
- action_186,
- action_187,
- action_188,
- action_189,
- action_190,
- action_191,
- action_192,
- action_193,
- action_194,
- action_195,
- action_196,
- action_197,
- action_198,
- action_199,
- action_200,
- action_201,
- action_202,
- action_203 :: () => Int -> ({-HappyReduction (Err) = -}
- Int
- -> (Token)
- -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)
- -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)]
- -> HappyStk HappyAbsSyn
- -> [(Token)] -> (Err) HappyAbsSyn)
-
-happyReduce_1,
- happyReduce_2,
- happyReduce_3,
- happyReduce_4,
- happyReduce_5,
- 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,
- happyReduce_37,
- happyReduce_38,
- happyReduce_39,
- happyReduce_40,
- happyReduce_41,
- happyReduce_42,
- happyReduce_43,
- happyReduce_44,
- happyReduce_45,
- happyReduce_46,
- happyReduce_47,
- happyReduce_48,
- happyReduce_49,
- happyReduce_50,
- happyReduce_51,
- happyReduce_52,
- happyReduce_53,
- happyReduce_54,
- happyReduce_55,
- happyReduce_56,
- happyReduce_57,
- happyReduce_58,
- happyReduce_59,
- happyReduce_60,
- happyReduce_61,
- happyReduce_62,
- happyReduce_63,
- happyReduce_64,
- happyReduce_65,
- happyReduce_66,
- happyReduce_67,
- happyReduce_68,
- happyReduce_69,
- happyReduce_70,
- happyReduce_71,
- happyReduce_72,
- happyReduce_73,
- happyReduce_74,
- happyReduce_75,
- happyReduce_76,
- happyReduce_77,
- happyReduce_78,
- happyReduce_79,
- happyReduce_80,
- happyReduce_81,
- happyReduce_82,
- happyReduce_83,
- happyReduce_84,
- happyReduce_85,
- happyReduce_86,
- happyReduce_87,
- happyReduce_88,
- happyReduce_89,
- happyReduce_90,
- happyReduce_91,
- happyReduce_92,
- happyReduce_93,
- happyReduce_94,
- happyReduce_95,
- happyReduce_96,
- happyReduce_97,
- happyReduce_98,
- happyReduce_99,
- happyReduce_100,
- happyReduce_101,
- happyReduce_102,
- happyReduce_103,
- happyReduce_104,
- happyReduce_105,
- happyReduce_106,
- happyReduce_107,
- happyReduce_108,
- happyReduce_109,
- happyReduce_110,
- happyReduce_111,
- happyReduce_112,
- happyReduce_113,
- happyReduce_114,
- happyReduce_115,
- happyReduce_116,
- happyReduce_117,
- happyReduce_118 :: () => ({-HappyReduction (Err) = -}
- Int
- -> (Token)
- -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)
- -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)]
- -> HappyStk HappyAbsSyn
- -> [(Token)] -> (Err) HappyAbsSyn)
-
-action_0 (84) = happyShift action_4
-action_0 (12) = happyGoto action_3
-action_0 _ = happyFail
-
-action_1 (91) = happyShift action_2
-action_1 _ = happyFail
-
-action_2 _ = happyReduce_1
-
-action_3 (100) = happyAccept
-action_3 _ = happyFail
-
-action_4 (94) = happyShift action_7
-action_4 (7) = happyGoto action_5
-action_4 (42) = happyGoto action_6
-action_4 _ = happyFail
-
-action_5 _ = happyReduce_82
-
-action_6 (79) = happyShift action_8
-action_6 _ = happyFail
-
-action_7 _ = happyReduce_4
-
-action_8 (60) = happyShift action_10
-action_8 (74) = happyShift action_11
-action_8 (13) = happyGoto action_9
-action_8 _ = happyFail
-
-action_9 (87) = happyShift action_19
-action_9 _ = happyFail
-
-action_10 (94) = happyShift action_7
-action_10 (95) = happyShift action_18
-action_10 (7) = happyGoto action_12
-action_10 (8) = happyGoto action_13
-action_10 (14) = happyGoto action_14
-action_10 (40) = happyGoto action_15
-action_10 (41) = happyGoto action_16
-action_10 (49) = happyGoto action_17
-action_10 _ = happyReduce_97
-
-action_11 _ = happyReduce_10
-
-action_12 _ = happyReduce_81
-
-action_13 _ = happyReduce_80
-
-action_14 (62) = happyShift action_24
-action_14 _ = happyReduce_98
-
-action_15 _ = happyReduce_13
-
-action_16 (60) = happyShift action_23
-action_16 (15) = happyGoto action_22
-action_16 _ = happyReduce_14
-
-action_17 (61) = happyShift action_21
-action_17 _ = happyFail
-
-action_18 _ = happyReduce_5
-
-action_19 (88) = happyShift action_20
-action_19 _ = happyFail
-
-action_20 (80) = happyShift action_31
-action_20 (81) = happyShift action_32
-action_20 (86) = happyShift action_33
-action_20 (95) = happyShift action_18
-action_20 (8) = happyGoto action_13
-action_20 (16) = happyGoto action_28
-action_20 (40) = happyGoto action_29
-action_20 (55) = happyGoto action_30
-action_20 _ = happyReduce_110
-
-action_21 _ = happyReduce_11
-
-action_22 _ = happyReduce_12
-
-action_23 (64) = happyShift action_26
-action_23 (65) = happyShift action_27
-action_23 _ = happyFail
-
-action_24 (94) = happyShift action_7
-action_24 (95) = happyShift action_18
-action_24 (7) = happyGoto action_12
-action_24 (8) = happyGoto action_13
-action_24 (14) = happyGoto action_14
-action_24 (40) = happyGoto action_15
-action_24 (41) = happyGoto action_16
-action_24 (49) = happyGoto action_25
-action_24 _ = happyReduce_97
-
-action_25 _ = happyReduce_99
-
-action_26 (61) = happyShift action_60
-action_26 _ = happyFail
-
-action_27 (61) = happyShift action_59
-action_27 _ = happyFail
-
-action_28 (67) = happyShift action_58
-action_28 _ = happyReduce_111
-
-action_29 (60) = happyShift action_49
-action_29 (66) = happyShift action_50
-action_29 (69) = happyShift action_51
-action_29 (71) = happyShift action_52
-action_29 (88) = happyShift action_53
-action_29 (91) = happyShift action_2
-action_29 (92) = happyShift action_54
-action_29 (93) = happyShift action_55
-action_29 (94) = happyShift action_7
-action_29 (95) = happyShift action_18
-action_29 (97) = happyShift action_56
-action_29 (98) = happyShift action_57
-action_29 (4) = happyGoto action_39
-action_29 (5) = happyGoto action_40
-action_29 (6) = happyGoto action_41
-action_29 (7) = happyGoto action_12
-action_29 (8) = happyGoto action_13
-action_29 (10) = happyGoto action_42
-action_29 (11) = happyGoto action_43
-action_29 (25) = happyGoto action_44
-action_29 (38) = happyGoto action_45
-action_29 (40) = happyGoto action_46
-action_29 (41) = happyGoto action_47
-action_29 (52) = happyGoto action_48
-action_29 _ = happyFail
-
-action_30 (90) = happyShift action_38
-action_30 _ = happyFail
-
-action_31 (91) = happyShift action_2
-action_31 (4) = happyGoto action_36
-action_31 (18) = happyGoto action_37
-action_31 _ = happyReduce_26
-
-action_32 (94) = happyShift action_7
-action_32 (7) = happyGoto action_5
-action_32 (42) = happyGoto action_35
-action_32 _ = happyFail
-
-action_33 (94) = happyShift action_7
-action_33 (7) = happyGoto action_12
-action_33 (41) = happyGoto action_34
-action_33 _ = happyFail
-
-action_34 (47) = happyGoto action_98
-action_34 _ = happyReduce_92
-
-action_35 (75) = happyShift action_97
-action_35 (17) = happyGoto action_96
-action_35 _ = happyReduce_24
-
-action_36 _ = happyReduce_25
-
-action_37 (95) = happyShift action_18
-action_37 (8) = happyGoto action_13
-action_37 (40) = happyGoto action_95
-action_37 _ = happyFail
-
-action_38 _ = happyReduce_9
-
-action_39 _ = happyReduce_75
-
-action_40 _ = happyReduce_74
-
-action_41 _ = happyReduce_77
-
-action_42 _ = happyReduce_76
-
-action_43 _ = happyReduce_48
-
-action_44 (60) = happyShift action_49
-action_44 (71) = happyShift action_52
-action_44 (88) = happyShift action_53
-action_44 (91) = happyShift action_2
-action_44 (92) = happyShift action_54
-action_44 (93) = happyShift action_55
-action_44 (94) = happyShift action_7
-action_44 (95) = happyShift action_18
-action_44 (97) = happyShift action_56
-action_44 (98) = happyShift action_57
-action_44 (4) = happyGoto action_39
-action_44 (5) = happyGoto action_40
-action_44 (6) = happyGoto action_41
-action_44 (7) = happyGoto action_12
-action_44 (8) = happyGoto action_13
-action_44 (10) = happyGoto action_42
-action_44 (11) = happyGoto action_43
-action_44 (25) = happyGoto action_44
-action_44 (38) = happyGoto action_45
-action_44 (40) = happyGoto action_46
-action_44 (41) = happyGoto action_47
-action_44 (52) = happyGoto action_94
-action_44 _ = happyReduce_104
-
-action_45 _ = happyReduce_50
-
-action_46 _ = happyReduce_49
-
-action_47 _ = happyReduce_78
-
-action_48 (69) = happyShift action_93
-action_48 _ = happyFail
-
-action_49 (60) = happyShift action_49
-action_49 (70) = happyShift action_75
-action_49 (71) = happyShift action_52
-action_49 (76) = happyShift action_76
-action_49 (77) = happyShift action_77
-action_49 (78) = happyShift action_78
-action_49 (83) = happyShift action_79
-action_49 (88) = happyShift action_53
-action_49 (91) = happyShift action_2
-action_49 (92) = happyShift action_54
-action_49 (93) = happyShift action_55
-action_49 (94) = happyShift action_7
-action_49 (95) = happyShift action_18
-action_49 (97) = happyShift action_56
-action_49 (98) = happyShift action_57
-action_49 (4) = happyGoto action_39
-action_49 (5) = happyGoto action_40
-action_49 (6) = happyGoto action_41
-action_49 (7) = happyGoto action_12
-action_49 (8) = happyGoto action_13
-action_49 (10) = happyGoto action_42
-action_49 (11) = happyGoto action_43
-action_49 (19) = happyGoto action_91
-action_49 (20) = happyGoto action_68
-action_49 (21) = happyGoto action_69
-action_49 (22) = happyGoto action_70
-action_49 (23) = happyGoto action_71
-action_49 (24) = happyGoto action_72
-action_49 (25) = happyGoto action_73
-action_49 (26) = happyGoto action_74
-action_49 (38) = happyGoto action_45
-action_49 (40) = happyGoto action_46
-action_49 (41) = happyGoto action_47
-action_49 (45) = happyGoto action_92
-action_49 _ = happyReduce_86
-
-action_50 (59) = happyShift action_88
-action_50 (60) = happyShift action_89
-action_50 (71) = happyShift action_90
-action_50 (94) = happyShift action_7
-action_50 (95) = happyShift action_18
-action_50 (98) = happyShift action_57
-action_50 (7) = happyGoto action_12
-action_50 (8) = happyGoto action_80
-action_50 (11) = happyGoto action_81
-action_50 (31) = happyGoto action_82
-action_50 (32) = happyGoto action_83
-action_50 (33) = happyGoto action_84
-action_50 (34) = happyGoto action_85
-action_50 (41) = happyGoto action_86
-action_50 (44) = happyGoto action_87
-action_50 _ = happyFail
-
-action_51 (60) = happyShift action_49
-action_51 (70) = happyShift action_75
-action_51 (71) = happyShift action_52
-action_51 (76) = happyShift action_76
-action_51 (77) = happyShift action_77
-action_51 (78) = happyShift action_78
-action_51 (83) = happyShift action_79
-action_51 (88) = happyShift action_53
-action_51 (91) = happyShift action_2
-action_51 (92) = happyShift action_54
-action_51 (93) = happyShift action_55
-action_51 (94) = happyShift action_7
-action_51 (95) = happyShift action_18
-action_51 (97) = happyShift action_56
-action_51 (98) = happyShift action_57
-action_51 (4) = happyGoto action_39
-action_51 (5) = happyGoto action_40
-action_51 (6) = happyGoto action_41
-action_51 (7) = happyGoto action_12
-action_51 (8) = happyGoto action_13
-action_51 (10) = happyGoto action_42
-action_51 (11) = happyGoto action_43
-action_51 (19) = happyGoto action_67
-action_51 (20) = happyGoto action_68
-action_51 (21) = happyGoto action_69
-action_51 (22) = happyGoto action_70
-action_51 (23) = happyGoto action_71
-action_51 (24) = happyGoto action_72
-action_51 (25) = happyGoto action_73
-action_51 (26) = happyGoto action_74
-action_51 (38) = happyGoto action_45
-action_51 (40) = happyGoto action_46
-action_51 (41) = happyGoto action_47
-action_51 _ = happyFail
-
-action_52 (72) = happyShift action_66
-action_52 _ = happyFail
-
-action_53 (95) = happyShift action_18
-action_53 (8) = happyGoto action_62
-action_53 (39) = happyGoto action_63
-action_53 (43) = happyGoto action_64
-action_53 (53) = happyGoto action_65
-action_53 _ = happyFail
-
-action_54 _ = happyReduce_2
-
-action_55 _ = happyReduce_3
-
-action_56 _ = happyReduce_7
-
-action_57 _ = happyReduce_8
-
-action_58 (80) = happyShift action_31
-action_58 (81) = happyShift action_32
-action_58 (86) = happyShift action_33
-action_58 (95) = happyShift action_18
-action_58 (8) = happyGoto action_13
-action_58 (16) = happyGoto action_28
-action_58 (40) = happyGoto action_29
-action_58 (55) = happyGoto action_61
-action_58 _ = happyReduce_110
-
-action_59 _ = happyReduce_16
-
-action_60 _ = happyReduce_15
-
-action_61 _ = happyReduce_112
-
-action_62 _ = happyReduce_83
-
-action_63 (62) = happyShift action_131
-action_63 _ = happyReduce_106
-
-action_64 (69) = happyShift action_130
-action_64 _ = happyFail
-
-action_65 (90) = happyShift action_129
-action_65 _ = happyFail
-
-action_66 (60) = happyShift action_49
-action_66 (70) = happyShift action_75
-action_66 (71) = happyShift action_52
-action_66 (76) = happyShift action_76
-action_66 (77) = happyShift action_77
-action_66 (78) = happyShift action_78
-action_66 (83) = happyShift action_79
-action_66 (88) = happyShift action_53
-action_66 (91) = happyShift action_2
-action_66 (92) = happyShift action_54
-action_66 (93) = happyShift action_55
-action_66 (94) = happyShift action_7
-action_66 (95) = happyShift action_18
-action_66 (97) = happyShift action_56
-action_66 (98) = happyShift action_57
-action_66 (4) = happyGoto action_39
-action_66 (5) = happyGoto action_40
-action_66 (6) = happyGoto action_41
-action_66 (7) = happyGoto action_12
-action_66 (8) = happyGoto action_13
-action_66 (10) = happyGoto action_42
-action_66 (11) = happyGoto action_43
-action_66 (19) = happyGoto action_127
-action_66 (20) = happyGoto action_68
-action_66 (21) = happyGoto action_69
-action_66 (22) = happyGoto action_70
-action_66 (23) = happyGoto action_71
-action_66 (24) = happyGoto action_72
-action_66 (25) = happyGoto action_73
-action_66 (26) = happyGoto action_74
-action_66 (38) = happyGoto action_45
-action_66 (40) = happyGoto action_46
-action_66 (41) = happyGoto action_47
-action_66 (45) = happyGoto action_128
-action_66 _ = happyReduce_86
-
-action_67 _ = happyReduce_21
-
-action_68 _ = happyReduce_28
-
-action_69 (68) = happyShift action_125
-action_69 (69) = happyShift action_126
-action_69 _ = happyReduce_34
-
-action_70 (60) = happyShift action_49
-action_70 (70) = happyShift action_75
-action_70 (71) = happyShift action_52
-action_70 (88) = happyShift action_53
-action_70 (91) = happyShift action_2
-action_70 (92) = happyShift action_54
-action_70 (93) = happyShift action_55
-action_70 (94) = happyShift action_7
-action_70 (95) = happyShift action_18
-action_70 (96) = happyShift action_124
-action_70 (97) = happyShift action_56
-action_70 (98) = happyShift action_57
-action_70 (4) = happyGoto action_39
-action_70 (5) = happyGoto action_40
-action_70 (6) = happyGoto action_41
-action_70 (7) = happyGoto action_12
-action_70 (8) = happyGoto action_13
-action_70 (9) = happyGoto action_122
-action_70 (10) = happyGoto action_42
-action_70 (11) = happyGoto action_43
-action_70 (23) = happyGoto action_123
-action_70 (24) = happyGoto action_72
-action_70 (25) = happyGoto action_73
-action_70 (26) = happyGoto action_74
-action_70 (38) = happyGoto action_45
-action_70 (40) = happyGoto action_46
-action_70 (41) = happyGoto action_47
-action_70 _ = happyReduce_36
-
-action_71 _ = happyReduce_38
-
-action_72 (64) = happyShift action_120
-action_72 (72) = happyShift action_121
-action_72 _ = happyReduce_40
-
-action_73 _ = happyReduce_43
-
-action_74 (60) = happyShift action_49
-action_74 (71) = happyShift action_52
-action_74 (88) = happyShift action_53
-action_74 (91) = happyShift action_2
-action_74 (92) = happyShift action_54
-action_74 (93) = happyShift action_55
-action_74 (94) = happyShift action_7
-action_74 (95) = happyShift action_18
-action_74 (97) = happyShift action_56
-action_74 (98) = happyShift action_57
-action_74 (4) = happyGoto action_39
-action_74 (5) = happyGoto action_40
-action_74 (6) = happyGoto action_41
-action_74 (7) = happyGoto action_12
-action_74 (8) = happyGoto action_13
-action_74 (10) = happyGoto action_42
-action_74 (11) = happyGoto action_43
-action_74 (24) = happyGoto action_119
-action_74 (25) = happyGoto action_73
-action_74 (38) = happyGoto action_45
-action_74 (40) = happyGoto action_46
-action_74 (41) = happyGoto action_47
-action_74 _ = happyFail
-
-action_75 _ = happyReduce_51
-
-action_76 (85) = happyShift action_118
-action_76 _ = happyFail
-
-action_77 (60) = happyShift action_49
-action_77 (70) = happyShift action_75
-action_77 (71) = happyShift action_52
-action_77 (76) = happyShift action_76
-action_77 (77) = happyShift action_77
-action_77 (78) = happyShift action_78
-action_77 (83) = happyShift action_79
-action_77 (88) = happyShift action_53
-action_77 (91) = happyShift action_2
-action_77 (92) = happyShift action_54
-action_77 (93) = happyShift action_55
-action_77 (94) = happyShift action_7
-action_77 (95) = happyShift action_18
-action_77 (97) = happyShift action_56
-action_77 (98) = happyShift action_57
-action_77 (4) = happyGoto action_39
-action_77 (5) = happyGoto action_40
-action_77 (6) = happyGoto action_41
-action_77 (7) = happyGoto action_12
-action_77 (8) = happyGoto action_13
-action_77 (10) = happyGoto action_42
-action_77 (11) = happyGoto action_43
-action_77 (19) = happyGoto action_117
-action_77 (20) = happyGoto action_68
-action_77 (21) = happyGoto action_69
-action_77 (22) = happyGoto action_70
-action_77 (23) = happyGoto action_71
-action_77 (24) = happyGoto action_72
-action_77 (25) = happyGoto action_73
-action_77 (26) = happyGoto action_74
-action_77 (38) = happyGoto action_45
-action_77 (40) = happyGoto action_46
-action_77 (41) = happyGoto action_47
-action_77 _ = happyFail
-
-action_78 (88) = happyShift action_116
-action_78 _ = happyFail
-
-action_79 (60) = happyShift action_49
-action_79 (70) = happyShift action_75
-action_79 (71) = happyShift action_52
-action_79 (88) = happyShift action_53
-action_79 (91) = happyShift action_2
-action_79 (92) = happyShift action_54
-action_79 (93) = happyShift action_55
-action_79 (94) = happyShift action_7
-action_79 (95) = happyShift action_18
-action_79 (97) = happyShift action_56
-action_79 (98) = happyShift action_57
-action_79 (4) = happyGoto action_39
-action_79 (5) = happyGoto action_40
-action_79 (6) = happyGoto action_41
-action_79 (7) = happyGoto action_12
-action_79 (8) = happyGoto action_13
-action_79 (10) = happyGoto action_42
-action_79 (11) = happyGoto action_43
-action_79 (21) = happyGoto action_115
-action_79 (22) = happyGoto action_70
-action_79 (23) = happyGoto action_71
-action_79 (24) = happyGoto action_72
-action_79 (25) = happyGoto action_73
-action_79 (26) = happyGoto action_74
-action_79 (38) = happyGoto action_45
-action_79 (40) = happyGoto action_46
-action_79 (41) = happyGoto action_47
-action_79 _ = happyFail
-
-action_80 _ = happyReduce_84
-
-action_81 _ = happyReduce_66
-
-action_82 _ = happyReduce_20
-
-action_83 (63) = happyShift action_114
-action_83 _ = happyReduce_60
-
-action_84 _ = happyReduce_63
-
-action_85 _ = happyReduce_64
-
-action_86 (59) = happyShift action_88
-action_86 (60) = happyShift action_89
-action_86 (94) = happyShift action_7
-action_86 (95) = happyShift action_18
-action_86 (98) = happyShift action_57
-action_86 (7) = happyGoto action_12
-action_86 (8) = happyGoto action_80
-action_86 (11) = happyGoto action_81
-action_86 (33) = happyGoto action_112
-action_86 (34) = happyGoto action_85
-action_86 (41) = happyGoto action_108
-action_86 (44) = happyGoto action_87
-action_86 (54) = happyGoto action_113
-action_86 _ = happyReduce_68
-
-action_87 _ = happyReduce_67
-
-action_88 (95) = happyShift action_18
-action_88 (8) = happyGoto action_111
-action_88 _ = happyFail
-
-action_89 (59) = happyShift action_88
-action_89 (60) = happyShift action_89
-action_89 (71) = happyShift action_90
-action_89 (94) = happyShift action_7
-action_89 (95) = happyShift action_18
-action_89 (98) = happyShift action_57
-action_89 (7) = happyGoto action_12
-action_89 (8) = happyGoto action_80
-action_89 (11) = happyGoto action_81
-action_89 (31) = happyGoto action_109
-action_89 (32) = happyGoto action_83
-action_89 (33) = happyGoto action_84
-action_89 (34) = happyGoto action_85
-action_89 (41) = happyGoto action_86
-action_89 (44) = happyGoto action_87
-action_89 (48) = happyGoto action_110
-action_89 _ = happyReduce_94
-
-action_90 (59) = happyShift action_88
-action_90 (60) = happyShift action_89
-action_90 (94) = happyShift action_7
-action_90 (95) = happyShift action_18
-action_90 (98) = happyShift action_57
-action_90 (7) = happyGoto action_12
-action_90 (8) = happyGoto action_80
-action_90 (11) = happyGoto action_81
-action_90 (33) = happyGoto action_107
-action_90 (34) = happyGoto action_85
-action_90 (41) = happyGoto action_108
-action_90 (44) = happyGoto action_87
-action_90 _ = happyFail
-
-action_91 (62) = happyShift action_105
-action_91 (66) = happyShift action_106
-action_91 _ = happyReduce_87
-
-action_92 (61) = happyShift action_104
-action_92 _ = happyFail
-
-action_93 (60) = happyShift action_49
-action_93 (70) = happyShift action_75
-action_93 (71) = happyShift action_52
-action_93 (76) = happyShift action_76
-action_93 (77) = happyShift action_77
-action_93 (78) = happyShift action_78
-action_93 (83) = happyShift action_79
-action_93 (88) = happyShift action_53
-action_93 (91) = happyShift action_2
-action_93 (92) = happyShift action_54
-action_93 (93) = happyShift action_55
-action_93 (94) = happyShift action_7
-action_93 (95) = happyShift action_18
-action_93 (97) = happyShift action_56
-action_93 (98) = happyShift action_57
-action_93 (4) = happyGoto action_39
-action_93 (5) = happyGoto action_40
-action_93 (6) = happyGoto action_41
-action_93 (7) = happyGoto action_12
-action_93 (8) = happyGoto action_13
-action_93 (10) = happyGoto action_42
-action_93 (11) = happyGoto action_43
-action_93 (19) = happyGoto action_103
-action_93 (20) = happyGoto action_68
-action_93 (21) = happyGoto action_69
-action_93 (22) = happyGoto action_70
-action_93 (23) = happyGoto action_71
-action_93 (24) = happyGoto action_72
-action_93 (25) = happyGoto action_73
-action_93 (26) = happyGoto action_74
-action_93 (38) = happyGoto action_45
-action_93 (40) = happyGoto action_46
-action_93 (41) = happyGoto action_47
-action_93 _ = happyFail
-
-action_94 _ = happyReduce_105
-
-action_95 (66) = happyShift action_102
-action_95 _ = happyFail
-
-action_96 _ = happyReduce_17
-
-action_97 (94) = happyShift action_7
-action_97 (7) = happyGoto action_12
-action_97 (41) = happyGoto action_101
-action_97 _ = happyFail
-
-action_98 (59) = happyShift action_88
-action_98 (69) = happyShift action_100
-action_98 (95) = happyShift action_18
-action_98 (8) = happyGoto action_80
-action_98 (44) = happyGoto action_99
-action_98 _ = happyFail
-
-action_99 _ = happyReduce_93
-
-action_100 (59) = happyShift action_88
-action_100 (60) = happyShift action_89
-action_100 (71) = happyShift action_90
-action_100 (88) = happyShift action_155
-action_100 (89) = happyShift action_156
-action_100 (94) = happyShift action_7
-action_100 (95) = happyShift action_18
-action_100 (98) = happyShift action_57
-action_100 (7) = happyGoto action_12
-action_100 (8) = happyGoto action_80
-action_100 (11) = happyGoto action_81
-action_100 (31) = happyGoto action_153
-action_100 (32) = happyGoto action_83
-action_100 (33) = happyGoto action_84
-action_100 (34) = happyGoto action_85
-action_100 (35) = happyGoto action_154
-action_100 (41) = happyGoto action_86
-action_100 (44) = happyGoto action_87
-action_100 _ = happyFail
-
-action_101 _ = happyReduce_23
-
-action_102 (59) = happyShift action_88
-action_102 (60) = happyShift action_89
-action_102 (71) = happyShift action_90
-action_102 (94) = happyShift action_7
-action_102 (95) = happyShift action_18
-action_102 (98) = happyShift action_57
-action_102 (7) = happyGoto action_12
-action_102 (8) = happyGoto action_80
-action_102 (11) = happyGoto action_81
-action_102 (31) = happyGoto action_152
-action_102 (32) = happyGoto action_83
-action_102 (33) = happyGoto action_84
-action_102 (34) = happyGoto action_85
-action_102 (41) = happyGoto action_86
-action_102 (44) = happyGoto action_87
-action_102 _ = happyFail
-
-action_103 _ = happyReduce_22
-
-action_104 _ = happyReduce_46
-
-action_105 (60) = happyShift action_49
-action_105 (70) = happyShift action_75
-action_105 (71) = happyShift action_52
-action_105 (76) = happyShift action_76
-action_105 (77) = happyShift action_77
-action_105 (78) = happyShift action_78
-action_105 (83) = happyShift action_79
-action_105 (88) = happyShift action_53
-action_105 (91) = happyShift action_2
-action_105 (92) = happyShift action_54
-action_105 (93) = happyShift action_55
-action_105 (94) = happyShift action_7
-action_105 (95) = happyShift action_18
-action_105 (97) = happyShift action_56
-action_105 (98) = happyShift action_57
-action_105 (4) = happyGoto action_39
-action_105 (5) = happyGoto action_40
-action_105 (6) = happyGoto action_41
-action_105 (7) = happyGoto action_12
-action_105 (8) = happyGoto action_13
-action_105 (10) = happyGoto action_42
-action_105 (11) = happyGoto action_43
-action_105 (19) = happyGoto action_127
-action_105 (20) = happyGoto action_68
-action_105 (21) = happyGoto action_69
-action_105 (22) = happyGoto action_70
-action_105 (23) = happyGoto action_71
-action_105 (24) = happyGoto action_72
-action_105 (25) = happyGoto action_73
-action_105 (26) = happyGoto action_74
-action_105 (38) = happyGoto action_45
-action_105 (40) = happyGoto action_46
-action_105 (41) = happyGoto action_47
-action_105 (45) = happyGoto action_151
-action_105 _ = happyReduce_86
-
-action_106 (59) = happyShift action_88
-action_106 (60) = happyShift action_89
-action_106 (71) = happyShift action_90
-action_106 (94) = happyShift action_7
-action_106 (95) = happyShift action_18
-action_106 (98) = happyShift action_57
-action_106 (7) = happyGoto action_12
-action_106 (8) = happyGoto action_80
-action_106 (11) = happyGoto action_81
-action_106 (31) = happyGoto action_150
-action_106 (32) = happyGoto action_83
-action_106 (33) = happyGoto action_84
-action_106 (34) = happyGoto action_85
-action_106 (41) = happyGoto action_86
-action_106 (44) = happyGoto action_87
-action_106 _ = happyFail
-
-action_107 (59) = happyShift action_88
-action_107 (60) = happyShift action_89
-action_107 (94) = happyShift action_7
-action_107 (95) = happyShift action_18
-action_107 (98) = happyShift action_57
-action_107 (7) = happyGoto action_12
-action_107 (8) = happyGoto action_80
-action_107 (11) = happyGoto action_81
-action_107 (33) = happyGoto action_149
-action_107 (34) = happyGoto action_85
-action_107 (41) = happyGoto action_108
-action_107 (44) = happyGoto action_87
-action_107 _ = happyFail
-
-action_108 _ = happyReduce_68
-
-action_109 (62) = happyShift action_148
-action_109 _ = happyReduce_95
-
-action_110 (61) = happyShift action_147
-action_110 _ = happyFail
-
-action_111 _ = happyReduce_85
-
-action_112 (59) = happyShift action_88
-action_112 (60) = happyShift action_89
-action_112 (94) = happyShift action_7
-action_112 (95) = happyShift action_18
-action_112 (98) = happyShift action_57
-action_112 (7) = happyGoto action_12
-action_112 (8) = happyGoto action_80
-action_112 (11) = happyGoto action_81
-action_112 (33) = happyGoto action_112
-action_112 (34) = happyGoto action_85
-action_112 (41) = happyGoto action_108
-action_112 (44) = happyGoto action_87
-action_112 (54) = happyGoto action_146
-action_112 _ = happyReduce_108
-
-action_113 _ = happyReduce_62
-
-action_114 (59) = happyShift action_88
-action_114 (60) = happyShift action_89
-action_114 (71) = happyShift action_90
-action_114 (94) = happyShift action_7
-action_114 (95) = happyShift action_18
-action_114 (98) = happyShift action_57
-action_114 (7) = happyGoto action_12
-action_114 (8) = happyGoto action_80
-action_114 (11) = happyGoto action_81
-action_114 (31) = happyGoto action_145
-action_114 (32) = happyGoto action_83
-action_114 (33) = happyGoto action_84
-action_114 (34) = happyGoto action_85
-action_114 (41) = happyGoto action_86
-action_114 (44) = happyGoto action_87
-action_114 _ = happyFail
-
-action_115 (69) = happyShift action_144
-action_115 _ = happyFail
-
-action_116 (60) = happyShift action_49
-action_116 (70) = happyShift action_75
-action_116 (71) = happyShift action_52
-action_116 (76) = happyShift action_76
-action_116 (77) = happyShift action_77
-action_116 (83) = happyShift action_79
-action_116 (88) = happyShift action_53
-action_116 (91) = happyShift action_2
-action_116 (92) = happyShift action_54
-action_116 (93) = happyShift action_55
-action_116 (94) = happyShift action_7
-action_116 (95) = happyShift action_18
-action_116 (97) = happyShift action_56
-action_116 (98) = happyShift action_57
-action_116 (4) = happyGoto action_39
-action_116 (5) = happyGoto action_40
-action_116 (6) = happyGoto action_41
-action_116 (7) = happyGoto action_12
-action_116 (8) = happyGoto action_13
-action_116 (10) = happyGoto action_42
-action_116 (11) = happyGoto action_43
-action_116 (20) = happyGoto action_142
-action_116 (21) = happyGoto action_69
-action_116 (22) = happyGoto action_70
-action_116 (23) = happyGoto action_71
-action_116 (24) = happyGoto action_72
-action_116 (25) = happyGoto action_73
-action_116 (26) = happyGoto action_74
-action_116 (38) = happyGoto action_45
-action_116 (40) = happyGoto action_46
-action_116 (41) = happyGoto action_47
-action_116 (58) = happyGoto action_143
-action_116 _ = happyFail
-
-action_117 (85) = happyShift action_141
-action_117 _ = happyFail
-
-action_118 (88) = happyShift action_140
-action_118 _ = happyFail
-
-action_119 (64) = happyShift action_120
-action_119 (72) = happyShift action_121
-action_119 _ = happyReduce_39
-
-action_120 (95) = happyShift action_18
-action_120 (8) = happyGoto action_62
-action_120 (43) = happyGoto action_139
-action_120 _ = happyFail
-
-action_121 (60) = happyShift action_49
-action_121 (70) = happyShift action_75
-action_121 (71) = happyShift action_52
-action_121 (76) = happyShift action_76
-action_121 (77) = happyShift action_77
-action_121 (78) = happyShift action_78
-action_121 (83) = happyShift action_79
-action_121 (88) = happyShift action_53
-action_121 (91) = happyShift action_2
-action_121 (92) = happyShift action_54
-action_121 (93) = happyShift action_55
-action_121 (94) = happyShift action_7
-action_121 (95) = happyShift action_18
-action_121 (97) = happyShift action_56
-action_121 (98) = happyShift action_57
-action_121 (4) = happyGoto action_39
-action_121 (5) = happyGoto action_40
-action_121 (6) = happyGoto action_41
-action_121 (7) = happyGoto action_12
-action_121 (8) = happyGoto action_13
-action_121 (10) = happyGoto action_42
-action_121 (11) = happyGoto action_43
-action_121 (19) = happyGoto action_138
-action_121 (20) = happyGoto action_68
-action_121 (21) = happyGoto action_69
-action_121 (22) = happyGoto action_70
-action_121 (23) = happyGoto action_71
-action_121 (24) = happyGoto action_72
-action_121 (25) = happyGoto action_73
-action_121 (26) = happyGoto action_74
-action_121 (38) = happyGoto action_45
-action_121 (40) = happyGoto action_46
-action_121 (41) = happyGoto action_47
-action_121 _ = happyFail
-
-action_122 (60) = happyShift action_49
-action_122 (70) = happyShift action_75
-action_122 (71) = happyShift action_52
-action_122 (88) = happyShift action_53
-action_122 (91) = happyShift action_2
-action_122 (92) = happyShift action_54
-action_122 (93) = happyShift action_55
-action_122 (94) = happyShift action_7
-action_122 (95) = happyShift action_18
-action_122 (97) = happyShift action_56
-action_122 (98) = happyShift action_57
-action_122 (4) = happyGoto action_39
-action_122 (5) = happyGoto action_40
-action_122 (6) = happyGoto action_41
-action_122 (7) = happyGoto action_12
-action_122 (8) = happyGoto action_13
-action_122 (10) = happyGoto action_42
-action_122 (11) = happyGoto action_43
-action_122 (22) = happyGoto action_137
-action_122 (23) = happyGoto action_71
-action_122 (24) = happyGoto action_72
-action_122 (25) = happyGoto action_73
-action_122 (26) = happyGoto action_74
-action_122 (38) = happyGoto action_45
-action_122 (40) = happyGoto action_46
-action_122 (41) = happyGoto action_47
-action_122 _ = happyFail
-
-action_123 _ = happyReduce_37
-
-action_124 _ = happyReduce_6
-
-action_125 (60) = happyShift action_49
-action_125 (70) = happyShift action_75
-action_125 (71) = happyShift action_52
-action_125 (76) = happyShift action_76
-action_125 (77) = happyShift action_77
-action_125 (78) = happyShift action_78
-action_125 (83) = happyShift action_79
-action_125 (88) = happyShift action_53
-action_125 (91) = happyShift action_2
-action_125 (92) = happyShift action_54
-action_125 (93) = happyShift action_55
-action_125 (94) = happyShift action_7
-action_125 (95) = happyShift action_18
-action_125 (97) = happyShift action_56
-action_125 (98) = happyShift action_57
-action_125 (4) = happyGoto action_39
-action_125 (5) = happyGoto action_40
-action_125 (6) = happyGoto action_41
-action_125 (7) = happyGoto action_12
-action_125 (8) = happyGoto action_13
-action_125 (10) = happyGoto action_42
-action_125 (11) = happyGoto action_43
-action_125 (19) = happyGoto action_136
-action_125 (20) = happyGoto action_68
-action_125 (21) = happyGoto action_69
-action_125 (22) = happyGoto action_70
-action_125 (23) = happyGoto action_71
-action_125 (24) = happyGoto action_72
-action_125 (25) = happyGoto action_73
-action_125 (26) = happyGoto action_74
-action_125 (38) = happyGoto action_45
-action_125 (40) = happyGoto action_46
-action_125 (41) = happyGoto action_47
-action_125 _ = happyFail
-
-action_126 (60) = happyShift action_49
-action_126 (70) = happyShift action_75
-action_126 (71) = happyShift action_52
-action_126 (76) = happyShift action_76
-action_126 (77) = happyShift action_77
-action_126 (78) = happyShift action_78
-action_126 (83) = happyShift action_79
-action_126 (88) = happyShift action_53
-action_126 (91) = happyShift action_2
-action_126 (92) = happyShift action_54
-action_126 (93) = happyShift action_55
-action_126 (94) = happyShift action_7
-action_126 (95) = happyShift action_18
-action_126 (97) = happyShift action_56
-action_126 (98) = happyShift action_57
-action_126 (4) = happyGoto action_39
-action_126 (5) = happyGoto action_40
-action_126 (6) = happyGoto action_41
-action_126 (7) = happyGoto action_12
-action_126 (8) = happyGoto action_13
-action_126 (10) = happyGoto action_42
-action_126 (11) = happyGoto action_43
-action_126 (19) = happyGoto action_135
-action_126 (20) = happyGoto action_68
-action_126 (21) = happyGoto action_69
-action_126 (22) = happyGoto action_70
-action_126 (23) = happyGoto action_71
-action_126 (24) = happyGoto action_72
-action_126 (25) = happyGoto action_73
-action_126 (26) = happyGoto action_74
-action_126 (38) = happyGoto action_45
-action_126 (40) = happyGoto action_46
-action_126 (41) = happyGoto action_47
-action_126 _ = happyFail
-
-action_127 (62) = happyShift action_105
-action_127 _ = happyReduce_87
-
-action_128 (73) = happyShift action_134
-action_128 _ = happyFail
-
-action_129 _ = happyReduce_45
-
-action_130 (60) = happyShift action_49
-action_130 (70) = happyShift action_75
-action_130 (71) = happyShift action_52
-action_130 (76) = happyShift action_76
-action_130 (77) = happyShift action_77
-action_130 (78) = happyShift action_78
-action_130 (83) = happyShift action_79
-action_130 (88) = happyShift action_53
-action_130 (91) = happyShift action_2
-action_130 (92) = happyShift action_54
-action_130 (93) = happyShift action_55
-action_130 (94) = happyShift action_7
-action_130 (95) = happyShift action_18
-action_130 (97) = happyShift action_56
-action_130 (98) = happyShift action_57
-action_130 (4) = happyGoto action_39
-action_130 (5) = happyGoto action_40
-action_130 (6) = happyGoto action_41
-action_130 (7) = happyGoto action_12
-action_130 (8) = happyGoto action_13
-action_130 (10) = happyGoto action_42
-action_130 (11) = happyGoto action_43
-action_130 (19) = happyGoto action_133
-action_130 (20) = happyGoto action_68
-action_130 (21) = happyGoto action_69
-action_130 (22) = happyGoto action_70
-action_130 (23) = happyGoto action_71
-action_130 (24) = happyGoto action_72
-action_130 (25) = happyGoto action_73
-action_130 (26) = happyGoto action_74
-action_130 (38) = happyGoto action_45
-action_130 (40) = happyGoto action_46
-action_130 (41) = happyGoto action_47
-action_130 _ = happyFail
-
-action_131 (95) = happyShift action_18
-action_131 (8) = happyGoto action_62
-action_131 (39) = happyGoto action_63
-action_131 (43) = happyGoto action_64
-action_131 (53) = happyGoto action_132
-action_131 _ = happyFail
-
-action_132 _ = happyReduce_107
-
-action_133 _ = happyReduce_79
-
-action_134 _ = happyReduce_44
-
-action_135 _ = happyReduce_29
-
-action_136 _ = happyReduce_31
-
-action_137 (60) = happyShift action_49
-action_137 (70) = happyShift action_75
-action_137 (71) = happyShift action_52
-action_137 (88) = happyShift action_53
-action_137 (91) = happyShift action_2
-action_137 (92) = happyShift action_54
-action_137 (93) = happyShift action_55
-action_137 (94) = happyShift action_7
-action_137 (95) = happyShift action_18
-action_137 (97) = happyShift action_56
-action_137 (98) = happyShift action_57
-action_137 (4) = happyGoto action_39
-action_137 (5) = happyGoto action_40
-action_137 (6) = happyGoto action_41
-action_137 (7) = happyGoto action_12
-action_137 (8) = happyGoto action_13
-action_137 (10) = happyGoto action_42
-action_137 (11) = happyGoto action_43
-action_137 (23) = happyGoto action_123
-action_137 (24) = happyGoto action_72
-action_137 (25) = happyGoto action_73
-action_137 (26) = happyGoto action_74
-action_137 (38) = happyGoto action_45
-action_137 (40) = happyGoto action_46
-action_137 (41) = happyGoto action_47
-action_137 _ = happyReduce_35
-
-action_138 (73) = happyShift action_172
-action_138 _ = happyFail
-
-action_139 _ = happyReduce_42
-
-action_140 (89) = happyShift action_171
-action_140 (29) = happyGoto action_169
-action_140 (57) = happyGoto action_170
-action_140 _ = happyFail
-
-action_141 (88) = happyShift action_168
-action_141 _ = happyFail
-
-action_142 (67) = happyShift action_167
-action_142 _ = happyReduce_117
-
-action_143 (90) = happyShift action_166
-action_143 _ = happyFail
-
-action_144 (60) = happyShift action_49
-action_144 (70) = happyShift action_75
-action_144 (71) = happyShift action_52
-action_144 (76) = happyShift action_76
-action_144 (77) = happyShift action_77
-action_144 (78) = happyShift action_78
-action_144 (83) = happyShift action_79
-action_144 (88) = happyShift action_53
-action_144 (91) = happyShift action_2
-action_144 (92) = happyShift action_54
-action_144 (93) = happyShift action_55
-action_144 (94) = happyShift action_7
-action_144 (95) = happyShift action_18
-action_144 (97) = happyShift action_56
-action_144 (98) = happyShift action_57
-action_144 (4) = happyGoto action_39
-action_144 (5) = happyGoto action_40
-action_144 (6) = happyGoto action_41
-action_144 (7) = happyGoto action_12
-action_144 (8) = happyGoto action_13
-action_144 (10) = happyGoto action_42
-action_144 (11) = happyGoto action_43
-action_144 (19) = happyGoto action_165
-action_144 (20) = happyGoto action_68
-action_144 (21) = happyGoto action_69
-action_144 (22) = happyGoto action_70
-action_144 (23) = happyGoto action_71
-action_144 (24) = happyGoto action_72
-action_144 (25) = happyGoto action_73
-action_144 (26) = happyGoto action_74
-action_144 (38) = happyGoto action_45
-action_144 (40) = happyGoto action_46
-action_144 (41) = happyGoto action_47
-action_144 _ = happyFail
-
-action_145 _ = happyReduce_59
-
-action_146 _ = happyReduce_109
-
-action_147 _ = happyReduce_65
-
-action_148 (59) = happyShift action_88
-action_148 (60) = happyShift action_89
-action_148 (71) = happyShift action_90
-action_148 (94) = happyShift action_7
-action_148 (95) = happyShift action_18
-action_148 (98) = happyShift action_57
-action_148 (7) = happyGoto action_12
-action_148 (8) = happyGoto action_80
-action_148 (11) = happyGoto action_81
-action_148 (31) = happyGoto action_109
-action_148 (32) = happyGoto action_83
-action_148 (33) = happyGoto action_84
-action_148 (34) = happyGoto action_85
-action_148 (41) = happyGoto action_86
-action_148 (44) = happyGoto action_87
-action_148 (48) = happyGoto action_164
-action_148 _ = happyReduce_94
-
-action_149 _ = happyReduce_61
-
-action_150 (61) = happyShift action_163
-action_150 _ = happyFail
-
-action_151 _ = happyReduce_88
-
-action_152 _ = happyReduce_18
-
-action_153 _ = happyReduce_71
-
-action_154 _ = happyReduce_19
-
-action_155 (95) = happyShift action_18
-action_155 (8) = happyGoto action_62
-action_155 (37) = happyGoto action_160
-action_155 (43) = happyGoto action_161
-action_155 (46) = happyGoto action_162
-action_155 _ = happyReduce_89
-
-action_156 (94) = happyShift action_7
-action_156 (7) = happyGoto action_12
-action_156 (36) = happyGoto action_157
-action_156 (41) = happyGoto action_158
-action_156 (51) = happyGoto action_159
-action_156 _ = happyFail
-
-action_157 (89) = happyShift action_189
-action_157 _ = happyReduce_102
-
-action_158 (50) = happyGoto action_188
-action_158 _ = happyReduce_100
-
-action_159 _ = happyReduce_70
-
-action_160 (62) = happyShift action_187
-action_160 _ = happyReduce_90
-
-action_161 (66) = happyShift action_186
-action_161 _ = happyFail
-
-action_162 (90) = happyShift action_185
-action_162 _ = happyFail
-
-action_163 _ = happyReduce_47
-
-action_164 _ = happyReduce_96
-
-action_165 (82) = happyShift action_184
-action_165 _ = happyFail
-
-action_166 _ = happyReduce_27
-
-action_167 (60) = happyShift action_49
-action_167 (70) = happyShift action_75
-action_167 (71) = happyShift action_52
-action_167 (76) = happyShift action_76
-action_167 (77) = happyShift action_77
-action_167 (83) = happyShift action_79
-action_167 (88) = happyShift action_53
-action_167 (91) = happyShift action_2
-action_167 (92) = happyShift action_54
-action_167 (93) = happyShift action_55
-action_167 (94) = happyShift action_7
-action_167 (95) = happyShift action_18
-action_167 (97) = happyShift action_56
-action_167 (98) = happyShift action_57
-action_167 (4) = happyGoto action_39
-action_167 (5) = happyGoto action_40
-action_167 (6) = happyGoto action_41
-action_167 (7) = happyGoto action_12
-action_167 (8) = happyGoto action_13
-action_167 (10) = happyGoto action_42
-action_167 (11) = happyGoto action_43
-action_167 (20) = happyGoto action_142
-action_167 (21) = happyGoto action_69
-action_167 (22) = happyGoto action_70
-action_167 (23) = happyGoto action_71
-action_167 (24) = happyGoto action_72
-action_167 (25) = happyGoto action_73
-action_167 (26) = happyGoto action_74
-action_167 (38) = happyGoto action_45
-action_167 (40) = happyGoto action_46
-action_167 (41) = happyGoto action_47
-action_167 (58) = happyGoto action_183
-action_167 _ = happyFail
-
-action_168 (91) = happyShift action_2
-action_168 (92) = happyShift action_54
-action_168 (93) = happyShift action_55
-action_168 (94) = happyShift action_7
-action_168 (95) = happyShift action_18
-action_168 (97) = happyShift action_56
-action_168 (4) = happyGoto action_39
-action_168 (5) = happyGoto action_40
-action_168 (6) = happyGoto action_41
-action_168 (7) = happyGoto action_12
-action_168 (8) = happyGoto action_13
-action_168 (10) = happyGoto action_42
-action_168 (27) = happyGoto action_177
-action_168 (28) = happyGoto action_178
-action_168 (38) = happyGoto action_179
-action_168 (40) = happyGoto action_180
-action_168 (41) = happyGoto action_181
-action_168 (56) = happyGoto action_182
-action_168 _ = happyFail
-
-action_169 (67) = happyShift action_176
-action_169 _ = happyReduce_115
-
-action_170 (90) = happyShift action_175
-action_170 _ = happyFail
-
-action_171 (60) = happyShift action_49
-action_171 (70) = happyShift action_75
-action_171 (71) = happyShift action_52
-action_171 (88) = happyShift action_53
-action_171 (91) = happyShift action_2
-action_171 (92) = happyShift action_54
-action_171 (93) = happyShift action_55
-action_171 (94) = happyShift action_7
-action_171 (95) = happyShift action_18
-action_171 (97) = happyShift action_56
-action_171 (98) = happyShift action_57
-action_171 (4) = happyGoto action_39
-action_171 (5) = happyGoto action_40
-action_171 (6) = happyGoto action_41
-action_171 (7) = happyGoto action_12
-action_171 (8) = happyGoto action_13
-action_171 (10) = happyGoto action_42
-action_171 (11) = happyGoto action_43
-action_171 (21) = happyGoto action_173
-action_171 (22) = happyGoto action_70
-action_171 (23) = happyGoto action_71
-action_171 (24) = happyGoto action_72
-action_171 (25) = happyGoto action_73
-action_171 (26) = happyGoto action_74
-action_171 (30) = happyGoto action_174
-action_171 (38) = happyGoto action_45
-action_171 (40) = happyGoto action_46
-action_171 (41) = happyGoto action_47
-action_171 _ = happyReduce_58
-
-action_172 _ = happyReduce_41
-
-action_173 _ = happyReduce_57
-
-action_174 (63) = happyShift action_200
-action_174 _ = happyFail
-
-action_175 _ = happyReduce_33
-
-action_176 (89) = happyShift action_171
-action_176 (29) = happyGoto action_169
-action_176 (57) = happyGoto action_199
-action_176 _ = happyFail
-
-action_177 (67) = happyShift action_198
-action_177 _ = happyReduce_113
-
-action_178 (63) = happyShift action_197
-action_178 _ = happyFail
-
-action_179 _ = happyReduce_54
-
-action_180 _ = happyReduce_55
-
-action_181 (95) = happyShift action_18
-action_181 (8) = happyGoto action_13
-action_181 (40) = happyGoto action_196
-action_181 _ = happyReduce_78
-
-action_182 (90) = happyShift action_195
-action_182 _ = happyFail
-
-action_183 _ = happyReduce_118
-
-action_184 (60) = happyShift action_49
-action_184 (70) = happyShift action_75
-action_184 (71) = happyShift action_52
-action_184 (76) = happyShift action_76
-action_184 (77) = happyShift action_77
-action_184 (78) = happyShift action_78
-action_184 (83) = happyShift action_79
-action_184 (88) = happyShift action_53
-action_184 (91) = happyShift action_2
-action_184 (92) = happyShift action_54
-action_184 (93) = happyShift action_55
-action_184 (94) = happyShift action_7
-action_184 (95) = happyShift action_18
-action_184 (97) = happyShift action_56
-action_184 (98) = happyShift action_57
-action_184 (4) = happyGoto action_39
-action_184 (5) = happyGoto action_40
-action_184 (6) = happyGoto action_41
-action_184 (7) = happyGoto action_12
-action_184 (8) = happyGoto action_13
-action_184 (10) = happyGoto action_42
-action_184 (11) = happyGoto action_43
-action_184 (19) = happyGoto action_194
-action_184 (20) = happyGoto action_68
-action_184 (21) = happyGoto action_69
-action_184 (22) = happyGoto action_70
-action_184 (23) = happyGoto action_71
-action_184 (24) = happyGoto action_72
-action_184 (25) = happyGoto action_73
-action_184 (26) = happyGoto action_74
-action_184 (38) = happyGoto action_45
-action_184 (40) = happyGoto action_46
-action_184 (41) = happyGoto action_47
-action_184 _ = happyFail
-
-action_185 _ = happyReduce_69
-
-action_186 (59) = happyShift action_88
-action_186 (60) = happyShift action_89
-action_186 (71) = happyShift action_90
-action_186 (94) = happyShift action_7
-action_186 (95) = happyShift action_18
-action_186 (98) = happyShift action_57
-action_186 (7) = happyGoto action_12
-action_186 (8) = happyGoto action_80
-action_186 (11) = happyGoto action_81
-action_186 (31) = happyGoto action_193
-action_186 (32) = happyGoto action_83
-action_186 (33) = happyGoto action_84
-action_186 (34) = happyGoto action_85
-action_186 (41) = happyGoto action_86
-action_186 (44) = happyGoto action_87
-action_186 _ = happyFail
-
-action_187 (95) = happyShift action_18
-action_187 (8) = happyGoto action_62
-action_187 (37) = happyGoto action_160
-action_187 (43) = happyGoto action_161
-action_187 (46) = happyGoto action_192
-action_187 _ = happyReduce_89
-
-action_188 (59) = happyShift action_88
-action_188 (60) = happyShift action_89
-action_188 (94) = happyShift action_7
-action_188 (95) = happyShift action_18
-action_188 (98) = happyShift action_57
-action_188 (7) = happyGoto action_12
-action_188 (8) = happyGoto action_80
-action_188 (11) = happyGoto action_81
-action_188 (34) = happyGoto action_191
-action_188 (41) = happyGoto action_108
-action_188 (44) = happyGoto action_87
-action_188 _ = happyReduce_72
-
-action_189 (94) = happyShift action_7
-action_189 (7) = happyGoto action_12
-action_189 (36) = happyGoto action_157
-action_189 (41) = happyGoto action_158
-action_189 (51) = happyGoto action_190
-action_189 _ = happyFail
-
-action_190 _ = happyReduce_103
-
-action_191 _ = happyReduce_101
-
-action_192 _ = happyReduce_91
-
-action_193 _ = happyReduce_73
-
-action_194 _ = happyReduce_30
-
-action_195 _ = happyReduce_32
-
-action_196 _ = happyReduce_53
-
-action_197 (60) = happyShift action_49
-action_197 (70) = happyShift action_75
-action_197 (71) = happyShift action_52
-action_197 (76) = happyShift action_76
-action_197 (77) = happyShift action_77
-action_197 (78) = happyShift action_78
-action_197 (83) = happyShift action_79
-action_197 (88) = happyShift action_53
-action_197 (91) = happyShift action_2
-action_197 (92) = happyShift action_54
-action_197 (93) = happyShift action_55
-action_197 (94) = happyShift action_7
-action_197 (95) = happyShift action_18
-action_197 (97) = happyShift action_56
-action_197 (98) = happyShift action_57
-action_197 (4) = happyGoto action_39
-action_197 (5) = happyGoto action_40
-action_197 (6) = happyGoto action_41
-action_197 (7) = happyGoto action_12
-action_197 (8) = happyGoto action_13
-action_197 (10) = happyGoto action_42
-action_197 (11) = happyGoto action_43
-action_197 (19) = happyGoto action_203
-action_197 (20) = happyGoto action_68
-action_197 (21) = happyGoto action_69
-action_197 (22) = happyGoto action_70
-action_197 (23) = happyGoto action_71
-action_197 (24) = happyGoto action_72
-action_197 (25) = happyGoto action_73
-action_197 (26) = happyGoto action_74
-action_197 (38) = happyGoto action_45
-action_197 (40) = happyGoto action_46
-action_197 (41) = happyGoto action_47
-action_197 _ = happyFail
-
-action_198 (91) = happyShift action_2
-action_198 (92) = happyShift action_54
-action_198 (93) = happyShift action_55
-action_198 (94) = happyShift action_7
-action_198 (95) = happyShift action_18
-action_198 (97) = happyShift action_56
-action_198 (4) = happyGoto action_39
-action_198 (5) = happyGoto action_40
-action_198 (6) = happyGoto action_41
-action_198 (7) = happyGoto action_12
-action_198 (8) = happyGoto action_13
-action_198 (10) = happyGoto action_42
-action_198 (27) = happyGoto action_177
-action_198 (28) = happyGoto action_178
-action_198 (38) = happyGoto action_179
-action_198 (40) = happyGoto action_180
-action_198 (41) = happyGoto action_181
-action_198 (56) = happyGoto action_202
-action_198 _ = happyFail
-
-action_199 _ = happyReduce_116
-
-action_200 (60) = happyShift action_49
-action_200 (70) = happyShift action_75
-action_200 (71) = happyShift action_52
-action_200 (76) = happyShift action_76
-action_200 (77) = happyShift action_77
-action_200 (78) = happyShift action_78
-action_200 (83) = happyShift action_79
-action_200 (88) = happyShift action_53
-action_200 (91) = happyShift action_2
-action_200 (92) = happyShift action_54
-action_200 (93) = happyShift action_55
-action_200 (94) = happyShift action_7
-action_200 (95) = happyShift action_18
-action_200 (97) = happyShift action_56
-action_200 (98) = happyShift action_57
-action_200 (4) = happyGoto action_39
-action_200 (5) = happyGoto action_40
-action_200 (6) = happyGoto action_41
-action_200 (7) = happyGoto action_12
-action_200 (8) = happyGoto action_13
-action_200 (10) = happyGoto action_42
-action_200 (11) = happyGoto action_43
-action_200 (19) = happyGoto action_201
-action_200 (20) = happyGoto action_68
-action_200 (21) = happyGoto action_69
-action_200 (22) = happyGoto action_70
-action_200 (23) = happyGoto action_71
-action_200 (24) = happyGoto action_72
-action_200 (25) = happyGoto action_73
-action_200 (26) = happyGoto action_74
-action_200 (38) = happyGoto action_45
-action_200 (40) = happyGoto action_46
-action_200 (41) = happyGoto action_47
-action_200 _ = happyFail
-
-action_201 _ = happyReduce_56
-
-action_202 _ = happyReduce_114
-
-action_203 _ = happyReduce_52
-
-happyReduce_1 = happySpecReduce_1 4 happyReduction_1
-happyReduction_1 (HappyTerminal (PT _ (TL happy_var_1)))
- = HappyAbsSyn4
- (happy_var_1
- )
-happyReduction_1 _ = notHappyAtAll
-
-happyReduce_2 = happySpecReduce_1 5 happyReduction_2
-happyReduction_2 (HappyTerminal (PT _ (TC happy_var_1)))
- = HappyAbsSyn5
- ((read ( happy_var_1)) :: Char
- )
-happyReduction_2 _ = notHappyAtAll
-
-happyReduce_3 = happySpecReduce_1 6 happyReduction_3
-happyReduction_3 (HappyTerminal (PT _ (T_Frac happy_var_1)))
- = HappyAbsSyn6
- (Frac (happy_var_1)
- )
-happyReduction_3 _ = notHappyAtAll
-
-happyReduce_4 = happySpecReduce_1 7 happyReduction_4
-happyReduction_4 (HappyTerminal (PT _ (T_Uident happy_var_1)))
- = HappyAbsSyn7
- (Uident (happy_var_1)
- )
-happyReduction_4 _ = notHappyAtAll
-
-happyReduce_5 = happySpecReduce_1 8 happyReduction_5
-happyReduction_5 (HappyTerminal (PT _ (T_Lident happy_var_1)))
- = HappyAbsSyn8
- (Lident (happy_var_1)
- )
-happyReduction_5 _ = notHappyAtAll
-
-happyReduce_6 = happySpecReduce_1 9 happyReduction_6
-happyReduction_6 (HappyTerminal (PT _ (T_USym happy_var_1)))
- = HappyAbsSyn9
- (USym (happy_var_1)
- )
-happyReduction_6 _ = notHappyAtAll
-
-happyReduce_7 = happySpecReduce_1 10 happyReduction_7
-happyReduction_7 (HappyTerminal (PT _ (T_Number happy_var_1)))
- = HappyAbsSyn10
- (Number (happy_var_1)
- )
-happyReduction_7 _ = notHappyAtAll
-
-happyReduce_8 = happySpecReduce_1 11 happyReduction_8
-happyReduction_8 (HappyTerminal (PT _ (T_Count happy_var_1)))
- = HappyAbsSyn11
- (Count (happy_var_1)
- )
-happyReduction_8 _ = notHappyAtAll
-
-happyReduce_9 = happyReduce 8 12 happyReduction_9
-happyReduction_9 (_ `HappyStk`
- (HappyAbsSyn55 happy_var_7) `HappyStk`
- _ `HappyStk`
- _ `HappyStk`
- (HappyAbsSyn13 happy_var_4) `HappyStk`
- _ `HappyStk`
- (HappyAbsSyn42 happy_var_2) `HappyStk`
- _ `HappyStk`
- happyRest)
- = HappyAbsSyn12
- (Module happy_var_2 happy_var_4 happy_var_7
- ) `HappyStk` happyRest
-
-happyReduce_10 = happySpecReduce_1 13 happyReduction_10
-happyReduction_10 _
- = HappyAbsSyn13
- (ExpAllD
- )
-
-happyReduce_11 = happySpecReduce_3 13 happyReduction_11
-happyReduction_11 _
- (HappyAbsSyn49 happy_var_2)
- _
- = HappyAbsSyn13
- (ExpListD happy_var_2
- )
-happyReduction_11 _ _ _ = notHappyAtAll
-
-happyReduce_12 = happySpecReduce_2 14 happyReduction_12
-happyReduction_12 (HappyAbsSyn15 happy_var_2)
- (HappyAbsSyn41 happy_var_1)
- = HappyAbsSyn14
- (TypeEx happy_var_1 happy_var_2
- )
-happyReduction_12 _ _ = notHappyAtAll
-
-happyReduce_13 = happySpecReduce_1 14 happyReduction_13
-happyReduction_13 (HappyAbsSyn40 happy_var_1)
- = HappyAbsSyn14
- (VarEx happy_var_1
- )
-happyReduction_13 _ = notHappyAtAll
-
-happyReduce_14 = happySpecReduce_0 15 happyReduction_14
-happyReduction_14 = HappyAbsSyn15
- (Neither
- )
-
-happyReduce_15 = happySpecReduce_3 15 happyReduction_15
-happyReduction_15 _
- _
- _
- = HappyAbsSyn15
- (Decon
- )
-
-happyReduce_16 = happySpecReduce_3 15 happyReduction_16
-happyReduction_16 _
- _
- _
- = HappyAbsSyn15
- (Both
- )
-
-happyReduce_17 = happySpecReduce_3 16 happyReduction_17
-happyReduction_17 (HappyAbsSyn17 happy_var_3)
- (HappyAbsSyn42 happy_var_2)
- _
- = HappyAbsSyn16
- (ImportD happy_var_2 happy_var_3
- )
-happyReduction_17 _ _ _ = notHappyAtAll
-
-happyReduce_18 = happyReduce 5 16 happyReduction_18
-happyReduction_18 ((HappyAbsSyn31 happy_var_5) `HappyStk`
- _ `HappyStk`
- (HappyAbsSyn40 happy_var_3) `HappyStk`
- (HappyAbsSyn18 happy_var_2) `HappyStk`
- _ `HappyStk`
- happyRest)
- = HappyAbsSyn16
- (ExternD happy_var_2 happy_var_3 happy_var_5
- ) `HappyStk` happyRest
-
-happyReduce_19 = happyReduce 5 16 happyReduction_19
-happyReduction_19 ((HappyAbsSyn35 happy_var_5) `HappyStk`
- _ `HappyStk`
- (HappyAbsSyn47 happy_var_3) `HappyStk`
- (HappyAbsSyn41 happy_var_2) `HappyStk`
- _ `HappyStk`
- happyRest)
- = HappyAbsSyn16
- (TypeD happy_var_2 (reverse happy_var_3) happy_var_5
- ) `HappyStk` happyRest
-
-happyReduce_20 = happySpecReduce_3 16 happyReduction_20
-happyReduction_20 (HappyAbsSyn31 happy_var_3)
- _
- (HappyAbsSyn40 happy_var_1)
- = HappyAbsSyn16
- (AscribeD happy_var_1 happy_var_3
- )
-happyReduction_20 _ _ _ = notHappyAtAll
-
-happyReduce_21 = happySpecReduce_3 16 happyReduction_21
-happyReduction_21 (HappyAbsSyn19 happy_var_3)
- _
- (HappyAbsSyn40 happy_var_1)
- = HappyAbsSyn16
- (VarD happy_var_1 happy_var_3
- )
-happyReduction_21 _ _ _ = notHappyAtAll
-
-happyReduce_22 = happyReduce 4 16 happyReduction_22
-happyReduction_22 ((HappyAbsSyn19 happy_var_4) `HappyStk`
- _ `HappyStk`
- (HappyAbsSyn45 happy_var_2) `HappyStk`
- (HappyAbsSyn40 happy_var_1) `HappyStk`
- happyRest)
- = HappyAbsSyn16
- (ProcD happy_var_1 happy_var_2 happy_var_4
- ) `HappyStk` happyRest
-
-happyReduce_23 = happySpecReduce_2 17 happyReduction_23
-happyReduction_23 (HappyAbsSyn41 happy_var_2)
- _
- = HappyAbsSyn17
- (AsAS happy_var_2
- )
-happyReduction_23 _ _ = notHappyAtAll
-
-happyReduce_24 = happySpecReduce_0 17 happyReduction_24
-happyReduction_24 = HappyAbsSyn17
- (EmptyAS
- )
-
-happyReduce_25 = happySpecReduce_1 18 happyReduction_25
-happyReduction_25 (HappyAbsSyn4 happy_var_1)
- = HappyAbsSyn18
- (SomeNm happy_var_1
- )
-happyReduction_25 _ = notHappyAtAll
-
-happyReduce_26 = happySpecReduce_0 18 happyReduction_26
-happyReduction_26 = HappyAbsSyn18
- (NoneNm
- )
-
-happyReduce_27 = happyReduce 4 19 happyReduction_27
-happyReduction_27 (_ `HappyStk`
- (HappyAbsSyn45 happy_var_3) `HappyStk`
- _ `HappyStk`
- _ `HappyStk`
- happyRest)
- = HappyAbsSyn19
- (BlockE happy_var_3
- ) `HappyStk` happyRest
-
-happyReduce_28 = happySpecReduce_1 19 happyReduction_28
-happyReduction_28 (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn19
- (happy_var_1
- )
-happyReduction_28 _ = notHappyAtAll
-
-happyReduce_29 = happySpecReduce_3 20 happyReduction_29
-happyReduction_29 (HappyAbsSyn19 happy_var_3)
- _
- (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn19
- (LetS happy_var_1 happy_var_3
- )
-happyReduction_29 _ _ _ = notHappyAtAll
-
-happyReduce_30 = happyReduce 6 20 happyReduction_30
-happyReduction_30 ((HappyAbsSyn19 happy_var_6) `HappyStk`
- _ `HappyStk`
- (HappyAbsSyn19 happy_var_4) `HappyStk`
- _ `HappyStk`
- (HappyAbsSyn19 happy_var_2) `HappyStk`
- _ `HappyStk`
- happyRest)
- = HappyAbsSyn19
- (LetE happy_var_2 happy_var_4 happy_var_6
- ) `HappyStk` happyRest
-
-happyReduce_31 = happySpecReduce_3 20 happyReduction_31
-happyReduction_31 (HappyAbsSyn19 happy_var_3)
- _
- (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn19
- (StoreE happy_var_1 happy_var_3
- )
-happyReduction_31 _ _ _ = notHappyAtAll
-
-happyReduce_32 = happyReduce 6 20 happyReduction_32
-happyReduction_32 (_ `HappyStk`
- (HappyAbsSyn56 happy_var_5) `HappyStk`
- _ `HappyStk`
- _ `HappyStk`
- (HappyAbsSyn19 happy_var_2) `HappyStk`
- _ `HappyStk`
- happyRest)
- = HappyAbsSyn19
- (CaseE happy_var_2 happy_var_5
- ) `HappyStk` happyRest
-
-happyReduce_33 = happyReduce 5 20 happyReduction_33
-happyReduction_33 (_ `HappyStk`
- (HappyAbsSyn57 happy_var_4) `HappyStk`
- _ `HappyStk`
- _ `HappyStk`
- _ `HappyStk`
- happyRest)
- = HappyAbsSyn19
- (BranchE happy_var_4
- ) `HappyStk` happyRest
-
-happyReduce_34 = happySpecReduce_1 20 happyReduction_34
-happyReduction_34 (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn19
- (happy_var_1
- )
-happyReduction_34 _ = notHappyAtAll
-
-happyReduce_35 = happySpecReduce_3 21 happyReduction_35
-happyReduction_35 (HappyAbsSyn19 happy_var_3)
- (HappyAbsSyn9 happy_var_2)
- (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn19
- (BinOpE happy_var_1 happy_var_2 happy_var_3
- )
-happyReduction_35 _ _ _ = notHappyAtAll
-
-happyReduce_36 = happySpecReduce_1 21 happyReduction_36
-happyReduction_36 (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn19
- (happy_var_1
- )
-happyReduction_36 _ = notHappyAtAll
-
-happyReduce_37 = happySpecReduce_2 22 happyReduction_37
-happyReduction_37 (HappyAbsSyn19 happy_var_2)
- (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn19
- (AppE happy_var_1 happy_var_2
- )
-happyReduction_37 _ _ = notHappyAtAll
-
-happyReduce_38 = happySpecReduce_1 22 happyReduction_38
-happyReduction_38 (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn19
- (happy_var_1
- )
-happyReduction_38 _ = notHappyAtAll
-
-happyReduce_39 = happySpecReduce_2 23 happyReduction_39
-happyReduction_39 (HappyAbsSyn19 happy_var_2)
- (HappyAbsSyn26 happy_var_1)
- = HappyAbsSyn19
- (UnOpE happy_var_1 happy_var_2
- )
-happyReduction_39 _ _ = notHappyAtAll
-
-happyReduce_40 = happySpecReduce_1 23 happyReduction_40
-happyReduction_40 (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn19
- (happy_var_1
- )
-happyReduction_40 _ = notHappyAtAll
-
-happyReduce_41 = happyReduce 4 24 happyReduction_41
-happyReduction_41 (_ `HappyStk`
- (HappyAbsSyn19 happy_var_3) `HappyStk`
- _ `HappyStk`
- (HappyAbsSyn19 happy_var_1) `HappyStk`
- happyRest)
- = HappyAbsSyn19
- (IdxE happy_var_1 happy_var_3
- ) `HappyStk` happyRest
-
-happyReduce_42 = happySpecReduce_3 24 happyReduction_42
-happyReduction_42 (HappyAbsSyn43 happy_var_3)
- _
- (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn19
- (FldE happy_var_1 happy_var_3
- )
-happyReduction_42 _ _ _ = notHappyAtAll
-
-happyReduce_43 = happySpecReduce_1 24 happyReduction_43
-happyReduction_43 (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn19
- (happy_var_1
- )
-happyReduction_43 _ = notHappyAtAll
-
-happyReduce_44 = happyReduce 4 25 happyReduction_44
-happyReduction_44 (_ `HappyStk`
- (HappyAbsSyn45 happy_var_3) `HappyStk`
- _ `HappyStk`
- _ `HappyStk`
- happyRest)
- = HappyAbsSyn19
- (ArrayE happy_var_3
- ) `HappyStk` happyRest
-
-happyReduce_45 = happySpecReduce_3 25 happyReduction_45
-happyReduction_45 _
- (HappyAbsSyn53 happy_var_2)
- _
- = HappyAbsSyn19
- (RecordE happy_var_2
- )
-happyReduction_45 _ _ _ = notHappyAtAll
-
-happyReduce_46 = happySpecReduce_3 25 happyReduction_46
-happyReduction_46 _
- (HappyAbsSyn45 happy_var_2)
- _
- = HappyAbsSyn19
- (TupleE happy_var_2
- )
-happyReduction_46 _ _ _ = notHappyAtAll
-
-happyReduce_47 = happyReduce 5 25 happyReduction_47
-happyReduction_47 (_ `HappyStk`
- (HappyAbsSyn31 happy_var_4) `HappyStk`
- _ `HappyStk`
- (HappyAbsSyn19 happy_var_2) `HappyStk`
- _ `HappyStk`
- happyRest)
- = HappyAbsSyn19
- (AscribeE happy_var_2 happy_var_4
- ) `HappyStk` happyRest
-
-happyReduce_48 = happySpecReduce_1 25 happyReduction_48
-happyReduction_48 (HappyAbsSyn11 happy_var_1)
- = HappyAbsSyn19
- (CountE happy_var_1
- )
-happyReduction_48 _ = notHappyAtAll
-
-happyReduce_49 = happySpecReduce_1 25 happyReduction_49
-happyReduction_49 (HappyAbsSyn40 happy_var_1)
- = HappyAbsSyn19
- (VarE happy_var_1
- )
-happyReduction_49 _ = notHappyAtAll
-
-happyReduce_50 = happySpecReduce_1 25 happyReduction_50
-happyReduction_50 (HappyAbsSyn38 happy_var_1)
- = HappyAbsSyn19
- (LitE happy_var_1
- )
-happyReduction_50 _ = notHappyAtAll
-
-happyReduce_51 = happySpecReduce_1 26 happyReduction_51
-happyReduction_51 _
- = HappyAbsSyn26
- (Load
- )
-
-happyReduce_52 = happySpecReduce_3 27 happyReduction_52
-happyReduction_52 (HappyAbsSyn19 happy_var_3)
- _
- (HappyAbsSyn28 happy_var_1)
- = HappyAbsSyn27
- (CaseAlt happy_var_1 happy_var_3
- )
-happyReduction_52 _ _ _ = notHappyAtAll
-
-happyReduce_53 = happySpecReduce_2 28 happyReduction_53
-happyReduction_53 (HappyAbsSyn40 happy_var_2)
- (HappyAbsSyn41 happy_var_1)
- = HappyAbsSyn28
- (ConP happy_var_1 happy_var_2
- )
-happyReduction_53 _ _ = notHappyAtAll
-
-happyReduce_54 = happySpecReduce_1 28 happyReduction_54
-happyReduction_54 (HappyAbsSyn38 happy_var_1)
- = HappyAbsSyn28
- (LitP happy_var_1
- )
-happyReduction_54 _ = notHappyAtAll
-
-happyReduce_55 = happySpecReduce_1 28 happyReduction_55
-happyReduction_55 (HappyAbsSyn40 happy_var_1)
- = HappyAbsSyn28
- (VarP happy_var_1
- )
-happyReduction_55 _ = notHappyAtAll
-
-happyReduce_56 = happyReduce 4 29 happyReduction_56
-happyReduction_56 ((HappyAbsSyn19 happy_var_4) `HappyStk`
- _ `HappyStk`
- (HappyAbsSyn30 happy_var_2) `HappyStk`
- _ `HappyStk`
- happyRest)
- = HappyAbsSyn29
- (BranchAlt happy_var_2 happy_var_4
- ) `HappyStk` happyRest
-
-happyReduce_57 = happySpecReduce_1 30 happyReduction_57
-happyReduction_57 (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn30
- (BoolBP happy_var_1
- )
-happyReduction_57 _ = notHappyAtAll
-
-happyReduce_58 = happySpecReduce_0 30 happyReduction_58
-happyReduction_58 = HappyAbsSyn30
- (DefaultBP
- )
-
-happyReduce_59 = happySpecReduce_3 31 happyReduction_59
-happyReduction_59 (HappyAbsSyn31 happy_var_3)
- _
- (HappyAbsSyn31 happy_var_1)
- = HappyAbsSyn31
- (TyFun happy_var_1 happy_var_3
- )
-happyReduction_59 _ _ _ = notHappyAtAll
-
-happyReduce_60 = happySpecReduce_1 31 happyReduction_60
-happyReduction_60 (HappyAbsSyn31 happy_var_1)
- = HappyAbsSyn31
- (happy_var_1
- )
-happyReduction_60 _ = notHappyAtAll
-
-happyReduce_61 = happySpecReduce_3 32 happyReduction_61
-happyReduction_61 (HappyAbsSyn31 happy_var_3)
- (HappyAbsSyn31 happy_var_2)
- _
- = HappyAbsSyn31
- (TyArray happy_var_2 happy_var_3
- )
-happyReduction_61 _ _ _ = notHappyAtAll
-
-happyReduce_62 = happySpecReduce_2 32 happyReduction_62
-happyReduction_62 (HappyAbsSyn48 happy_var_2)
- (HappyAbsSyn41 happy_var_1)
- = HappyAbsSyn31
- (TyConstr happy_var_1 happy_var_2
- )
-happyReduction_62 _ _ = notHappyAtAll
-
-happyReduce_63 = happySpecReduce_1 32 happyReduction_63
-happyReduction_63 (HappyAbsSyn31 happy_var_1)
- = HappyAbsSyn31
- (happy_var_1
- )
-happyReduction_63 _ = notHappyAtAll
-
-happyReduce_64 = happySpecReduce_1 33 happyReduction_64
-happyReduction_64 (HappyAbsSyn31 happy_var_1)
- = HappyAbsSyn31
- (happy_var_1
- )
-happyReduction_64 _ = notHappyAtAll
-
-happyReduce_65 = happySpecReduce_3 34 happyReduction_65
-happyReduction_65 _
- (HappyAbsSyn48 happy_var_2)
- _
- = HappyAbsSyn31
- (TyTuple happy_var_2
- )
-happyReduction_65 _ _ _ = notHappyAtAll
-
-happyReduce_66 = happySpecReduce_1 34 happyReduction_66
-happyReduction_66 (HappyAbsSyn11 happy_var_1)
- = HappyAbsSyn31
- (TyCount happy_var_1
- )
-happyReduction_66 _ = notHappyAtAll
-
-happyReduce_67 = happySpecReduce_1 34 happyReduction_67
-happyReduction_67 (HappyAbsSyn44 happy_var_1)
- = HappyAbsSyn31
- (TyVarT happy_var_1
- )
-happyReduction_67 _ = notHappyAtAll
-
-happyReduce_68 = happySpecReduce_1 34 happyReduction_68
-happyReduction_68 (HappyAbsSyn41 happy_var_1)
- = HappyAbsSyn31
- (TyConstr0 happy_var_1
- )
-happyReduction_68 _ = notHappyAtAll
-
-happyReduce_69 = happySpecReduce_3 35 happyReduction_69
-happyReduction_69 _
- (HappyAbsSyn46 happy_var_2)
- _
- = HappyAbsSyn35
- (TyRecord happy_var_2
- )
-happyReduction_69 _ _ _ = notHappyAtAll
-
-happyReduce_70 = happySpecReduce_2 35 happyReduction_70
-happyReduction_70 (HappyAbsSyn51 happy_var_2)
- _
- = HappyAbsSyn35
- (TyTagged happy_var_2
- )
-happyReduction_70 _ _ = notHappyAtAll
-
-happyReduce_71 = happySpecReduce_1 35 happyReduction_71
-happyReduction_71 (HappyAbsSyn31 happy_var_1)
- = HappyAbsSyn35
- (TySyn happy_var_1
- )
-happyReduction_71 _ = notHappyAtAll
-
-happyReduce_72 = happySpecReduce_2 36 happyReduction_72
-happyReduction_72 (HappyAbsSyn48 happy_var_2)
- (HappyAbsSyn41 happy_var_1)
- = HappyAbsSyn36
- (ConC happy_var_1 (reverse happy_var_2)
- )
-happyReduction_72 _ _ = notHappyAtAll
-
-happyReduce_73 = happySpecReduce_3 37 happyReduction_73
-happyReduction_73 (HappyAbsSyn31 happy_var_3)
- _
- (HappyAbsSyn43 happy_var_1)
- = HappyAbsSyn37
- (FieldT happy_var_1 happy_var_3
- )
-happyReduction_73 _ _ _ = notHappyAtAll
-
-happyReduce_74 = happySpecReduce_1 38 happyReduction_74
-happyReduction_74 (HappyAbsSyn5 happy_var_1)
- = HappyAbsSyn38
- (CharL happy_var_1
- )
-happyReduction_74 _ = notHappyAtAll
-
-happyReduce_75 = happySpecReduce_1 38 happyReduction_75
-happyReduction_75 (HappyAbsSyn4 happy_var_1)
- = HappyAbsSyn38
- (StringL happy_var_1
- )
-happyReduction_75 _ = notHappyAtAll
-
-happyReduce_76 = happySpecReduce_1 38 happyReduction_76
-happyReduction_76 (HappyAbsSyn10 happy_var_1)
- = HappyAbsSyn38
- (IntL happy_var_1
- )
-happyReduction_76 _ = notHappyAtAll
-
-happyReduce_77 = happySpecReduce_1 38 happyReduction_77
-happyReduction_77 (HappyAbsSyn6 happy_var_1)
- = HappyAbsSyn38
- (FracL happy_var_1
- )
-happyReduction_77 _ = notHappyAtAll
-
-happyReduce_78 = happySpecReduce_1 38 happyReduction_78
-happyReduction_78 (HappyAbsSyn41 happy_var_1)
- = HappyAbsSyn38
- (EnumL happy_var_1
- )
-happyReduction_78 _ = notHappyAtAll
-
-happyReduce_79 = happySpecReduce_3 39 happyReduction_79
-happyReduction_79 (HappyAbsSyn19 happy_var_3)
- _
- (HappyAbsSyn43 happy_var_1)
- = HappyAbsSyn39
- (FieldD happy_var_1 happy_var_3
- )
-happyReduction_79 _ _ _ = notHappyAtAll
-
-happyReduce_80 = happySpecReduce_1 40 happyReduction_80
-happyReduction_80 (HappyAbsSyn8 happy_var_1)
- = HappyAbsSyn40
- (Var happy_var_1
- )
-happyReduction_80 _ = notHappyAtAll
-
-happyReduce_81 = happySpecReduce_1 41 happyReduction_81
-happyReduction_81 (HappyAbsSyn7 happy_var_1)
- = HappyAbsSyn41
- (Con happy_var_1
- )
-happyReduction_81 _ = notHappyAtAll
-
-happyReduce_82 = happySpecReduce_1 42 happyReduction_82
-happyReduction_82 (HappyAbsSyn7 happy_var_1)
- = HappyAbsSyn42
- (Modid happy_var_1
- )
-happyReduction_82 _ = notHappyAtAll
-
-happyReduce_83 = happySpecReduce_1 43 happyReduction_83
-happyReduction_83 (HappyAbsSyn8 happy_var_1)
- = HappyAbsSyn43
- (Field happy_var_1
- )
-happyReduction_83 _ = notHappyAtAll
-
-happyReduce_84 = happySpecReduce_1 44 happyReduction_84
-happyReduction_84 (HappyAbsSyn8 happy_var_1)
- = HappyAbsSyn44
- (VarTV happy_var_1
- )
-happyReduction_84 _ = notHappyAtAll
-
-happyReduce_85 = happySpecReduce_2 44 happyReduction_85
-happyReduction_85 (HappyAbsSyn8 happy_var_2)
- _
- = HappyAbsSyn44
- (CntTV happy_var_2
- )
-happyReduction_85 _ _ = notHappyAtAll
-
-happyReduce_86 = happySpecReduce_0 45 happyReduction_86
-happyReduction_86 = HappyAbsSyn45
- ([]
- )
-
-happyReduce_87 = happySpecReduce_1 45 happyReduction_87
-happyReduction_87 (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn45
- ((:[]) happy_var_1
- )
-happyReduction_87 _ = notHappyAtAll
-
-happyReduce_88 = happySpecReduce_3 45 happyReduction_88
-happyReduction_88 (HappyAbsSyn45 happy_var_3)
- _
- (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn45
- ((:) happy_var_1 happy_var_3
- )
-happyReduction_88 _ _ _ = notHappyAtAll
-
-happyReduce_89 = happySpecReduce_0 46 happyReduction_89
-happyReduction_89 = HappyAbsSyn46
- ([]
- )
-
-happyReduce_90 = happySpecReduce_1 46 happyReduction_90
-happyReduction_90 (HappyAbsSyn37 happy_var_1)
- = HappyAbsSyn46
- ((:[]) happy_var_1
- )
-happyReduction_90 _ = notHappyAtAll
-
-happyReduce_91 = happySpecReduce_3 46 happyReduction_91
-happyReduction_91 (HappyAbsSyn46 happy_var_3)
- _
- (HappyAbsSyn37 happy_var_1)
- = HappyAbsSyn46
- ((:) happy_var_1 happy_var_3
- )
-happyReduction_91 _ _ _ = notHappyAtAll
-
-happyReduce_92 = happySpecReduce_0 47 happyReduction_92
-happyReduction_92 = HappyAbsSyn47
- ([]
- )
-
-happyReduce_93 = happySpecReduce_2 47 happyReduction_93
-happyReduction_93 (HappyAbsSyn44 happy_var_2)
- (HappyAbsSyn47 happy_var_1)
- = HappyAbsSyn47
- (flip (:) happy_var_1 happy_var_2
- )
-happyReduction_93 _ _ = notHappyAtAll
-
-happyReduce_94 = happySpecReduce_0 48 happyReduction_94
-happyReduction_94 = HappyAbsSyn48
- ([]
- )
-
-happyReduce_95 = happySpecReduce_1 48 happyReduction_95
-happyReduction_95 (HappyAbsSyn31 happy_var_1)
- = HappyAbsSyn48
- ((:[]) happy_var_1
- )
-happyReduction_95 _ = notHappyAtAll
-
-happyReduce_96 = happySpecReduce_3 48 happyReduction_96
-happyReduction_96 (HappyAbsSyn48 happy_var_3)
- _
- (HappyAbsSyn31 happy_var_1)
- = HappyAbsSyn48
- ((:) happy_var_1 happy_var_3
- )
-happyReduction_96 _ _ _ = notHappyAtAll
-
-happyReduce_97 = happySpecReduce_0 49 happyReduction_97
-happyReduction_97 = HappyAbsSyn49
- ([]
- )
-
-happyReduce_98 = happySpecReduce_1 49 happyReduction_98
-happyReduction_98 (HappyAbsSyn14 happy_var_1)
- = HappyAbsSyn49
- ((:[]) happy_var_1
- )
-happyReduction_98 _ = notHappyAtAll
-
-happyReduce_99 = happySpecReduce_3 49 happyReduction_99
-happyReduction_99 (HappyAbsSyn49 happy_var_3)
- _
- (HappyAbsSyn14 happy_var_1)
- = HappyAbsSyn49
- ((:) happy_var_1 happy_var_3
- )
-happyReduction_99 _ _ _ = notHappyAtAll
-
-happyReduce_100 = happySpecReduce_0 50 happyReduction_100
-happyReduction_100 = HappyAbsSyn48
- ([]
- )
-
-happyReduce_101 = happySpecReduce_2 50 happyReduction_101
-happyReduction_101 (HappyAbsSyn31 happy_var_2)
- (HappyAbsSyn48 happy_var_1)
- = HappyAbsSyn48
- (flip (:) happy_var_1 happy_var_2
- )
-happyReduction_101 _ _ = notHappyAtAll
-
-happyReduce_102 = happySpecReduce_1 51 happyReduction_102
-happyReduction_102 (HappyAbsSyn36 happy_var_1)
- = HappyAbsSyn51
- ((:[]) happy_var_1
- )
-happyReduction_102 _ = notHappyAtAll
-
-happyReduce_103 = happySpecReduce_3 51 happyReduction_103
-happyReduction_103 (HappyAbsSyn51 happy_var_3)
- _
- (HappyAbsSyn36 happy_var_1)
- = HappyAbsSyn51
- ((:) happy_var_1 happy_var_3
- )
-happyReduction_103 _ _ _ = notHappyAtAll
-
-happyReduce_104 = happySpecReduce_1 52 happyReduction_104
-happyReduction_104 (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn45
- ((:[]) happy_var_1
- )
-happyReduction_104 _ = notHappyAtAll
-
-happyReduce_105 = happySpecReduce_2 52 happyReduction_105
-happyReduction_105 (HappyAbsSyn45 happy_var_2)
- (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn45
- ((:) happy_var_1 happy_var_2
- )
-happyReduction_105 _ _ = notHappyAtAll
-
-happyReduce_106 = happySpecReduce_1 53 happyReduction_106
-happyReduction_106 (HappyAbsSyn39 happy_var_1)
- = HappyAbsSyn53
- ((:[]) happy_var_1
- )
-happyReduction_106 _ = notHappyAtAll
-
-happyReduce_107 = happySpecReduce_3 53 happyReduction_107
-happyReduction_107 (HappyAbsSyn53 happy_var_3)
- _
- (HappyAbsSyn39 happy_var_1)
- = HappyAbsSyn53
- ((:) happy_var_1 happy_var_3
- )
-happyReduction_107 _ _ _ = notHappyAtAll
-
-happyReduce_108 = happySpecReduce_1 54 happyReduction_108
-happyReduction_108 (HappyAbsSyn31 happy_var_1)
- = HappyAbsSyn48
- ((:[]) happy_var_1
- )
-happyReduction_108 _ = notHappyAtAll
-
-happyReduce_109 = happySpecReduce_2 54 happyReduction_109
-happyReduction_109 (HappyAbsSyn48 happy_var_2)
- (HappyAbsSyn31 happy_var_1)
- = HappyAbsSyn48
- ((:) happy_var_1 happy_var_2
- )
-happyReduction_109 _ _ = notHappyAtAll
-
-happyReduce_110 = happySpecReduce_0 55 happyReduction_110
-happyReduction_110 = HappyAbsSyn55
- ([]
- )
-
-happyReduce_111 = happySpecReduce_1 55 happyReduction_111
-happyReduction_111 (HappyAbsSyn16 happy_var_1)
- = HappyAbsSyn55
- ((:[]) happy_var_1
- )
-happyReduction_111 _ = notHappyAtAll
-
-happyReduce_112 = happySpecReduce_3 55 happyReduction_112
-happyReduction_112 (HappyAbsSyn55 happy_var_3)
- _
- (HappyAbsSyn16 happy_var_1)
- = HappyAbsSyn55
- ((:) happy_var_1 happy_var_3
- )
-happyReduction_112 _ _ _ = notHappyAtAll
-
-happyReduce_113 = happySpecReduce_1 56 happyReduction_113
-happyReduction_113 (HappyAbsSyn27 happy_var_1)
- = HappyAbsSyn56
- ((:[]) happy_var_1
- )
-happyReduction_113 _ = notHappyAtAll
-
-happyReduce_114 = happySpecReduce_3 56 happyReduction_114
-happyReduction_114 (HappyAbsSyn56 happy_var_3)
- _
- (HappyAbsSyn27 happy_var_1)
- = HappyAbsSyn56
- ((:) happy_var_1 happy_var_3
- )
-happyReduction_114 _ _ _ = notHappyAtAll
-
-happyReduce_115 = happySpecReduce_1 57 happyReduction_115
-happyReduction_115 (HappyAbsSyn29 happy_var_1)
- = HappyAbsSyn57
- ((:[]) happy_var_1
- )
-happyReduction_115 _ = notHappyAtAll
-
-happyReduce_116 = happySpecReduce_3 57 happyReduction_116
-happyReduction_116 (HappyAbsSyn57 happy_var_3)
- _
- (HappyAbsSyn29 happy_var_1)
- = HappyAbsSyn57
- ((:) happy_var_1 happy_var_3
- )
-happyReduction_116 _ _ _ = notHappyAtAll
-
-happyReduce_117 = happySpecReduce_1 58 happyReduction_117
-happyReduction_117 (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn45
- ((:[]) happy_var_1
- )
-happyReduction_117 _ = notHappyAtAll
-
-happyReduce_118 = happySpecReduce_3 58 happyReduction_118
-happyReduction_118 (HappyAbsSyn45 happy_var_3)
- _
- (HappyAbsSyn19 happy_var_1)
- = HappyAbsSyn45
- ((:) happy_var_1 happy_var_3
- )
-happyReduction_118 _ _ _ = notHappyAtAll
-
-happyNewToken action sts stk [] =
- action 100 100 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 59;
- PT _ (TS _ 2) -> cont 60;
- PT _ (TS _ 3) -> cont 61;
- PT _ (TS _ 4) -> cont 62;
- PT _ (TS _ 5) -> cont 63;
- PT _ (TS _ 6) -> cont 64;
- PT _ (TS _ 7) -> cont 65;
- PT _ (TS _ 8) -> cont 66;
- PT _ (TS _ 9) -> cont 67;
- PT _ (TS _ 10) -> cont 68;
- PT _ (TS _ 11) -> cont 69;
- PT _ (TS _ 12) -> cont 70;
- PT _ (TS _ 13) -> cont 71;
- PT _ (TS _ 14) -> cont 72;
- PT _ (TS _ 15) -> cont 73;
- PT _ (TS _ 16) -> cont 74;
- PT _ (TS _ 17) -> cont 75;
- PT _ (TS _ 18) -> cont 76;
- PT _ (TS _ 19) -> cont 77;
- PT _ (TS _ 20) -> cont 78;
- PT _ (TS _ 21) -> cont 79;
- PT _ (TS _ 22) -> cont 80;
- PT _ (TS _ 23) -> cont 81;
- PT _ (TS _ 24) -> cont 82;
- PT _ (TS _ 25) -> cont 83;
- PT _ (TS _ 26) -> cont 84;
- PT _ (TS _ 27) -> cont 85;
- PT _ (TS _ 28) -> cont 86;
- PT _ (TS _ 29) -> cont 87;
- PT _ (TS _ 30) -> cont 88;
- PT _ (TS _ 31) -> cont 89;
- PT _ (TS _ 32) -> cont 90;
- PT _ (TL happy_dollar_dollar) -> cont 91;
- PT _ (TC happy_dollar_dollar) -> cont 92;
- PT _ (T_Frac happy_dollar_dollar) -> cont 93;
- PT _ (T_Uident happy_dollar_dollar) -> cont 94;
- PT _ (T_Lident happy_dollar_dollar) -> cont 95;
- PT _ (T_USym happy_dollar_dollar) -> cont 96;
- PT _ (T_Number happy_dollar_dollar) -> cont 97;
- PT _ (T_Count happy_dollar_dollar) -> cont 98;
- _ -> cont 99;
- _ -> happyError' (tk:tks)
- }
-
-happyError_ tk tks = happyError' (tk:tks)
-
-happyThen :: () => Err a -> (a -> Err b) -> Err b
-happyThen = (thenM)
-happyReturn :: () => a -> Err a
-happyReturn = (returnM)
-happyThen1 m k tks = (thenM) m (\a -> k a tks)
-happyReturn1 :: () => a -> b -> Err a
-happyReturn1 = \a tks -> (returnM) a
-happyError' :: () => [(Token)] -> Err a
-happyError' = happyError
-
-pModule tks = happySomeParser where
- happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn12 z -> happyReturn z; _other -> notHappyAtAll })
-
-happySeq = happyDontSeq
-
-
-returnM :: a -> Err a
-returnM = return
-
-thenM :: Err a -> (a -> Err b) -> Err b
-thenM = (>>=)
-
-happyError :: [Token] -> Err a
-happyError ts =
- Bad $ "syntax error at " ++ tokenPos ts ++
- case ts of
- [] -> []
- [Err _] -> " due to lexer error"
- _ -> " before " ++ unwords (map (id . prToken) (take 4 ts))
-
-myLexer = tokens
-{-# LINE 1 "templates/GenericTemplate.hs" #-}
-{-# LINE 1 "templates/GenericTemplate.hs" #-}
-{-# LINE 1 "" #-}
-{-# LINE 1 "" #-}
-{-# LINE 1 "templates/GenericTemplate.hs" #-}
--- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp
-
-{-# LINE 30 "templates/GenericTemplate.hs" #-}
-
-
-
-
-
-
-
-
-{-# LINE 51 "templates/GenericTemplate.hs" #-}
-
-{-# LINE 61 "templates/GenericTemplate.hs" #-}
-
-{-# LINE 70 "templates/GenericTemplate.hs" #-}
-
-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 (1), 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
-
-{-# LINE 148 "templates/GenericTemplate.hs" #-}
-
------------------------------------------------------------------------------
--- HappyState data type (not arrays)
-
-
-
-newtype HappyState b c = HappyState
- (Int -> -- token number
- 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 - ((1) :: 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 =
- happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))
- where (sts1@(((st1@(HappyState (action))):(_)))) = happyDrop k ((st):(sts))
- drop_stk = happyDropStk k 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 =
- happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))
- where (sts1@(((st1@(HappyState (action))):(_)))) = happyDrop k ((st):(sts))
- drop_stk = happyDropStk k stk
-
-
-
-
-
- new_state = action
-
-
-happyDrop (0) l = l
-happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t
-
-happyDropStk (0) l = l
-happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs
-
------------------------------------------------------------------------------
--- Moving to a new state after a reduction
-
-{-# LINE 246 "templates/GenericTemplate.hs" #-}
-happyGoto action j tk st = action j j tk (HappyState action)
-
-
------------------------------------------------------------------------------
--- Error recovery ((1) is the error token)
-
--- parse error if we are in recovery and we fail again
-happyFail (1) tk old_st _ stk =
--- trace "failing" $
- happyError_ 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 (1) tk old_st (((HappyState (action))):(sts))
- (saved_tok `HappyStk` _ `HappyStk` stk) =
--- trace ("discarding state, depth " ++ show (length stk)) $
- action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))
--}
-
--- Enter error recovery: generate an error token,
--- save the old token and carry on.
-happyFail 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 = 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 `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.
-
-{-# LINE 311 "templates/GenericTemplate.hs" #-}
-{-# 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/Language/Pec/Par.y b/Language/Pec/Par.y
new file mode 100644
--- /dev/null
+++ b/Language/Pec/Par.y
@@ -0,0 +1,423 @@
+{
+{-# OPTIONS -w #-}
+-- Haskell module generated by grm *** DO NOT EDIT ***
+
+
+module Language.Pec.Par where
+import Grm.Prims
+import Grm.Lex
+import Language.Pec.Abs
+}
+%tokentype { (Token Point) }
+%name grmParse
+%token
+ "#" { TSymbol _ "#" }
+ "(" { TSymbol _ "(" }
+ ")" { TSymbol _ ")" }
+ "," { TSymbol _ "," }
+ "->" { TSymbol _ "->" }
+ "." { TSymbol _ "." }
+ ".." { TSymbol _ ".." }
+ "::" { TSymbol _ "::" }
+ ";" { TSymbol _ ";" }
+ "<-" { TSymbol _ "<-" }
+ "=" { TSymbol _ "=" }
+ "=>" { TSymbol _ "=>" }
+ "@" { TSymbol _ "@" }
+ "Array" { TSymbol _ "Array" }
+ "[" { TSymbol _ "[" }
+ "\\" { TSymbol _ "\\" }
+ "]" { TSymbol _ "]" }
+ "as" { TSymbol _ "as" }
+ "branch" { TSymbol _ "branch" }
+ "case" { TSymbol _ "case" }
+ "do" { TSymbol _ "do" }
+ "exports" { TSymbol _ "exports" }
+ "extern" { TSymbol _ "extern" }
+ "imports" { TSymbol _ "imports" }
+ "in" { TSymbol _ "in" }
+ "instance" { TSymbol _ "instance" }
+ "let" { TSymbol _ "let" }
+ "module" { TSymbol _ "module" }
+ "of" { TSymbol _ "of" }
+ "switch" { TSymbol _ "switch" }
+ "type" { TSymbol _ "type" }
+ "where" { TSymbol _ "where" }
+ "{" { TSymbol _ "{" }
+ "|" { TSymbol _ "|" }
+ "}" { TSymbol _ "}" }
+
+ uident { TUident _ _ }
+ usym { TUsym _ _ }
+ lident { TLident _ _ }
+ string { TString _ _ }
+ char { TChar _ _ }
+ number { TNumber _ _ }
+%%
+Module
+ : "module" Modid ExportDecls ImportDecls "where" "{" TopDeclList "}" {Module (lrPoint [point $1
+ ,point $2
+ ,point $3
+ ,point $4
+ ,point $5
+ ,point $6
+ ,lrPointList $7
+ ,point $8]) $2 $3 $4 $7 }
+
+ExportDecls
+ : "exports" "{" ExportList "}" {ExpListD (lrPoint [point $1
+ ,point $2
+ ,lrPointList $3
+ ,point $4]) $3 }
+ | {ExpAllD noPoint}
+ImportDecls
+ : "imports" "{" ImportList "}" {ImpListD (lrPoint [point $1
+ ,point $2
+ ,lrPointList $3
+ ,point $4]) $3 }
+ | {ImpNoneD noPoint}
+Export
+ : Con Spec {TypeEx (lrPoint [point $1
+ ,point $2]) $1 $2}
+ | Var {VarEx (point $1) $1}
+Import
+ : Modid AsSpec {Import (lrPoint [point $1
+ ,point $2]) $1 $2}
+
+AsSpec
+ : "as" Modid {AsAS (lrPoint [point $1
+ ,point $2]) $2}
+ | {EmptyAS noPoint}
+Spec
+ : {Neither noPoint}
+ | "(" "." ")" {Decon (lrPoint [point $1
+ ,point $2
+ ,point $3]) }
+ | "(" ".." ")" {Both (lrPoint [point $1
+ ,point $2
+ ,point $3]) }
+TopDecl
+ : "extern" ExtNm Var "::" Type {ExternD (lrPoint [point $1
+ ,point $2
+ ,point $3
+ ,point $4
+ ,point $5]) $2 $3 $5}
+ | "type" Con VarList "=" TyDecl {TypeD (lrPoint [point $1
+ ,point $2
+ ,lrPointList $3
+ ,point $4
+ ,point $5]) $2 $3 $5}
+ | "type" Con VarList {TypeD0 (lrPoint [point $1
+ ,point $2
+ ,lrPointList $3]) $2 $3}
+ | Var "::" Type {AscribeD (lrPoint [point $1
+ ,point $2
+ ,point $3]) $1 $3}
+ | Var DeclSym Exp {VarD (lrPoint [point $1
+ ,point $2
+ ,point $3]) $1 $2 $3}
+ | Var Exp0List DeclSym Exp {ProcD (lrPoint [point $1
+ ,lrPointList $2
+ ,point $3
+ ,point $4]) $1 $2 $3 $4}
+ | "instance" Con Type {InstD (lrPoint [point $1
+ ,point $2
+ ,point $3]) $2 $3}
+DeclSym
+ : "=>" {Macro (point $1) }
+ | "=" {Define (point $1) }
+ExtNm
+ : string {SomeNm (point $1) (unTString $1)}
+ | {NoneNm noPoint}
+Exp
+ : "do" "{" Exp5List "}" {BlockE (lrPoint [point $1
+ ,point $2
+ ,lrPointList $3
+ ,point $4]) $3 }
+ | Exp5 { $1 }
+Exp5
+ : Exp4 DeclSym Exp {LetS (lrPoint [point $1
+ ,point $2
+ ,point $3]) $1 $2 $3}
+ | "let" Exp4 DeclSym Exp "in" Exp {LetE (lrPoint [point $1
+ ,point $2
+ ,point $3
+ ,point $4
+ ,point $5
+ ,point $6]) $2 $3 $4 $6}
+ | "\\" Exp0List "->" Exp {LamE (lrPoint [point $1
+ ,lrPointList $2
+ ,point $3
+ ,point $4]) $2 $4}
+ | Exp4 "<-" Exp {StoreE (lrPoint [point $1
+ ,point $2
+ ,point $3]) $1 $3}
+ | "case" Exp "of" "{" CaseAltList DefaultAlt "}" {CaseE (lrPoint [point $1
+ ,point $2
+ ,point $3
+ ,point $4
+ ,lrPointList $5
+ ,point $6
+ ,point $7]) $2 $5 $6 }
+ | "switch" Exp "of" "{" SwitchAltList DefaultAlt "}" {SwitchE (lrPoint [point $1
+ ,point $2
+ ,point $3
+ ,point $4
+ ,lrPointList $5
+ ,point $6
+ ,point $7]) $2 $5 $6 }
+ | "branch" "{" BranchAltList "|" Exp ";" "}" {BranchE (lrPoint [point $1
+ ,point $2
+ ,lrPointList $3
+ ,point $4
+ ,point $5
+ ,point $6
+ ,point $7]) $3 $5 }
+ | Exp4 { $1 }
+Exp4
+ : Exp3 usym Exp3 {BinOpE (lrPoint [point $1
+ ,point $2
+ ,point $3]) $1 (unTUsym $2) $3}
+ | Exp3 { $1 }
+Exp3
+ : Exp3 Exp2 {AppE (lrPoint [point $1
+ ,point $2]) $1 $2}
+ | Exp2 { $1 }
+Exp2
+ : UnOp Exp1 {UnOpE (lrPoint [point $1
+ ,point $2]) $1 $2}
+ | Exp1 { $1 }
+Exp1
+ : Exp1 "[" Exp "]" {IdxE (lrPoint [point $1
+ ,point $2
+ ,point $3
+ ,point $4]) $1 $3 }
+ | Exp1 "." Field {FldE (lrPoint [point $1
+ ,point $2
+ ,point $3]) $1 $3}
+ | Exp0 { $1 }
+Exp0
+ : "Array" "[" ExpList "]" {ArrayE (lrPoint [point $1
+ ,point $2
+ ,lrPointList $3
+ ,point $4]) $3 }
+ | "{" FieldDList "}" {RecordE (lrPoint [point $1
+ ,lrPointList $2
+ ,point $3]) $2 }
+ | "(" ExpList ")" {TupleE (lrPoint [point $1
+ ,lrPointList $2
+ ,point $3]) $2 }
+ | "(" Exp "::" Type ")" {AscribeE (lrPoint [point $1
+ ,point $2
+ ,point $3
+ ,point $4
+ ,point $5]) $2 $4 }
+ | Count {CountE (point $1) $1}
+ | Var {VarE (point $1) $1}
+ | Lit {LitE (point $1) $1}
+UnOp
+ : "@" {Load (point $1) }
+
+CaseAlt
+ : Con VarList "->" Exp {CaseAlt (lrPoint [point $1
+ ,lrPointList $2
+ ,point $3
+ ,point $4]) $1 $2 $4}
+
+SwitchAlt
+ : Lit "->" Exp {SwitchAlt (lrPoint [point $1
+ ,point $2
+ ,point $3]) $1 $3}
+
+DefaultAlt
+ : Var "->" Exp ";" {DefaultAlt (lrPoint [point $1
+ ,point $2
+ ,point $3
+ ,point $4]) $1 $3 }
+ | {DefaultNone noPoint}
+BranchAlt
+ : Exp4 "->" Exp {BranchAlt (lrPoint [point $1
+ ,point $2
+ ,point $3]) $1 $3}
+
+Cxt
+ : Con VarList {Cxt (lrPoint [point $1
+ ,lrPointList $2]) $1 $2}
+
+Type
+ : "{" CxtList "}" "=>" Type3 {TyCxt (lrPoint [point $1
+ ,lrPointList $2
+ ,point $3
+ ,point $4
+ ,point $5]) $2 $5}
+ | Type3 { $1 }
+Type3
+ : Type2 "->" Type3 {TyFun (lrPoint [point $1
+ ,point $2
+ ,point $3]) $1 $3}
+ | Type2 { $1 }
+Type2
+ : "Array" Type1 Type1 {TyArray (lrPoint [point $1
+ ,point $2
+ ,point $3]) $2 $3}
+ | Con Type1List {TyConstr (lrPoint [point $1
+ ,lrPointList $2]) $1 $2}
+ | Type1 { $1 }
+Type1
+ : Type0 { $1 }
+
+Type0
+ : "(" TypeList ")" {TyTuple (lrPoint [point $1
+ ,lrPointList $2
+ ,point $3]) $2 }
+ | Count {TyCount (point $1) $1}
+ | TyVar {TyVarT (point $1) $1}
+ | Con {TyConstr0 (point $1) $1}
+TyDecl
+ : "{" FieldTList "}" {TyRecord (lrPoint [point $1
+ ,lrPointList $2
+ ,point $3]) $2 }
+ | "|" ConCList {TyTagged (lrPoint [point $1
+ ,lrPointList $2]) $2}
+ | Type {TySyn (point $1) $1}
+ConC
+ : Con Type0List {ConC (lrPoint [point $1
+ ,lrPointList $2]) $1 $2}
+
+FieldT
+ : Field "::" Type {FieldT (lrPoint [point $1
+ ,point $2
+ ,point $3]) $1 $3}
+
+Lit
+ : char {CharL (point $1) (unTChar $1)}
+ | string {StringL (point $1) (unTString $1)}
+ | number {NmbrL (point $1) (unTNumber $1)}
+ | Con {EnumL (point $1) $1}
+FieldD
+ : Field "=" Exp {FieldD (lrPoint [point $1
+ ,point $2
+ ,point $3]) $1 $3}
+
+Count
+ : "#" number {Count (lrPoint [point $1
+ ,point $2]) (unTNumber $2)}
+
+Var
+ : lident {Var (point $1) (unTLident $1)}
+
+Con
+ : uident {Con (point $1) (unTUident $1)}
+
+Modid
+ : uident {Modid (point $1) (unTUident $1)}
+
+Field
+ : lident {Field (point $1) (unTLident $1)}
+
+TyVar
+ : lident {VarTV (point $1) (unTLident $1)}
+ | "#" lident {CntTV (lrPoint [point $1
+ ,point $2]) (unTLident $2)}
+BranchAltList
+ : REV_BranchAltList {reverse $1}
+ | {- empty -} { [] }
+REV_BranchAltList
+ : BranchAlt ";" {[$1]}
+ | REV_BranchAltList BranchAlt ";" {$2 : $1}
+CaseAltList
+ : REV_CaseAltList {reverse $1}
+ | {- empty -} { [] }
+REV_CaseAltList
+ : CaseAlt ";" {[$1]}
+ | REV_CaseAltList CaseAlt ";" {$2 : $1}
+SwitchAltList
+ : REV_SwitchAltList {reverse $1}
+ | {- empty -} { [] }
+REV_SwitchAltList
+ : SwitchAlt ";" {[$1]}
+ | REV_SwitchAltList SwitchAlt ";" {$2 : $1}
+TopDeclList
+ : REV_TopDeclList {reverse $1}
+ | {- empty -} { [] }
+REV_TopDeclList
+ : TopDecl ";" {[$1]}
+ | REV_TopDeclList TopDecl ";" {$2 : $1}
+ImportList
+ : REV_ImportList {reverse $1}
+
+REV_ImportList
+ : Import ";" {[$1]}
+ | REV_ImportList Import ";" {$2 : $1}
+Exp5List
+ : REV_Exp5List {reverse $1}
+
+REV_Exp5List
+ : Exp5 ";" {[$1]}
+ | REV_Exp5List Exp5 ";" {$2 : $1}
+ExportList
+ : REV_ExportList {reverse $1}
+
+REV_ExportList
+ : Export ";" {[$1]}
+ | REV_ExportList Export ";" {$2 : $1}
+ConCList
+ : REV_ConCList {reverse $1}
+
+REV_ConCList
+ : ConC {[$1]}
+ | REV_ConCList "|" ConC {$3 : $1}
+Exp0List
+ : REV_Exp0List {reverse $1}
+
+REV_Exp0List
+ : Exp0 {[$1]}
+ | REV_Exp0List Exp0 {$2 : $1}
+VarList
+ : REV_VarList {reverse $1}
+ | {- empty -} { [] }
+REV_VarList
+ : Var {[$1]}
+ | REV_VarList Var {$2 : $1}
+ExpList
+ : REV_ExpList {reverse $1}
+ | {- empty -} { [] }
+REV_ExpList
+ : Exp {[$1]}
+ | REV_ExpList "," Exp {$3 : $1}
+FieldDList
+ : REV_FieldDList {reverse $1}
+
+REV_FieldDList
+ : FieldD {[$1]}
+ | REV_FieldDList "," FieldD {$3 : $1}
+FieldTList
+ : REV_FieldTList {reverse $1}
+
+REV_FieldTList
+ : FieldT {[$1]}
+ | REV_FieldTList "," FieldT {$3 : $1}
+Type0List
+ : REV_Type0List {reverse $1}
+ | {- empty -} { [] }
+REV_Type0List
+ : Type0 {[$1]}
+ | REV_Type0List Type0 {$2 : $1}
+Type1List
+ : REV_Type1List {reverse $1}
+
+REV_Type1List
+ : Type1 {[$1]}
+ | REV_Type1List Type1 {$2 : $1}
+TypeList
+ : REV_TypeList {reverse $1}
+ | {- empty -} { [] }
+REV_TypeList
+ : Type3 {[$1]}
+ | REV_TypeList "," Type3 {$3 : $1}
+CxtList
+ : REV_CxtList {reverse $1}
+
+REV_CxtList
+ : Cxt {[$1]}
+ | REV_CxtList "," Cxt {$3 : $1}
diff --git a/Language/Pec/Print.hs b/Language/Pec/Print.hs
deleted file mode 100644
--- a/Language/Pec/Print.hs
+++ /dev/null
@@ -1,314 +0,0 @@
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
-module Language.Pec.Print where
-
--- pretty-printer generated by the BNF converter
-
-import Language.Pec.Abs
-import Data.Char
-
-
--- 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 (map ($ "") $ d []) "" where
- rend i ss = case ss of
- "[" :ts -> showChar '[' . rend i ts
- "(" :ts -> showChar '(' . rend i ts
- "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
- "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
- "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
- ";" :ts -> showChar ';' . new i . rend i ts
- t : "," :ts -> showString t . space "," . rend i ts
- t : ")" :ts -> showString t . showChar ')' . rend i ts
- t : "]" :ts -> showString t . showChar ']' . rend i ts
- t :ts -> space t . rend i ts
- _ -> id
- new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
- space t = showString t . (\s -> if null s then "" else (' ':s))
-
-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
- prtList :: [a] -> Doc
- prtList = concatD . map (prt 0)
-
-instance Print a => Print [a] where
- prt _ = prtList
-
-instance Print Char where
- prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
- prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
-
-mkEsc :: Char -> Char -> ShowS
-mkEsc q s = case s of
- _ | s == q -> showChar '\\' . showChar s
- '\\'-> showString "\\\\"
- '\n' -> showString "\\n"
- '\t' -> showString "\\t"
- _ -> showChar s
-
-prPrec :: Int -> Int -> Doc -> Doc
-prPrec i j = if j prPrec i 0 (concatD [doc (showString "module") , prt 0 modid , doc (showString "exports") , prt 0 exportdecl , doc (showString "where") , doc (showString "{") , prt 0 topdecls , doc (showString "}")])
-
-
-instance Print ExportDecl where
- prt i e = case e of
- ExpAllD -> prPrec i 0 (concatD [doc (showString "all")])
- ExpListD exports -> prPrec i 0 (concatD [doc (showString "(") , prt 0 exports , doc (showString ")")])
-
-
-instance Print Export where
- prt i e = case e of
- TypeEx con spec -> prPrec i 0 (concatD [prt 0 con , prt 0 spec])
- VarEx var -> prPrec i 0 (concatD [prt 0 var])
-
- prtList es = case es of
- [] -> (concatD [])
- [x] -> (concatD [prt 0 x])
- x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
-
-instance Print Spec where
- prt i e = case e of
- Neither -> prPrec i 0 (concatD [])
- Decon -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ".") , doc (showString ")")])
- Both -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "..") , doc (showString ")")])
-
-
-instance Print TopDecl where
- prt i e = case e of
- ImportD modid asspec -> prPrec i 0 (concatD [doc (showString "import") , prt 0 modid , prt 0 asspec])
- ExternD extnm var type' -> prPrec i 0 (concatD [doc (showString "extern") , prt 0 extnm , prt 0 var , doc (showString "::") , prt 0 type'])
- TypeD con tyvars tydecl -> prPrec i 0 (concatD [doc (showString "type") , prt 0 con , prt 0 tyvars , doc (showString "=") , prt 0 tydecl])
- AscribeD var type' -> prPrec i 0 (concatD [prt 0 var , doc (showString "::") , prt 0 type'])
- VarD var exp -> prPrec i 0 (concatD [prt 0 var , doc (showString "=") , prt 0 exp])
- ProcD var exps exp -> prPrec i 0 (concatD [prt 0 var , prt 0 exps , doc (showString "=") , prt 0 exp])
-
- prtList es = case es of
- [] -> (concatD [])
- [x] -> (concatD [prt 0 x])
- x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
-
-instance Print AsSpec where
- prt i e = case e of
- AsAS con -> prPrec i 0 (concatD [doc (showString "as") , prt 0 con])
- EmptyAS -> prPrec i 0 (concatD [])
-
-
-instance Print ExtNm where
- prt i e = case e of
- SomeNm str -> prPrec i 0 (concatD [prt 0 str])
- NoneNm -> prPrec i 0 (concatD [])
-
-
-instance Print Exp where
- prt i e = case e of
- BlockE exps -> prPrec i 0 (concatD [doc (showString "do") , doc (showString "{") , prt 5 exps , doc (showString "}")])
- LetS exp0 exp -> prPrec i 5 (concatD [prt 4 exp0 , doc (showString "=") , prt 0 exp])
- LetE exp0 exp1 exp -> prPrec i 5 (concatD [doc (showString "let") , prt 4 exp0 , doc (showString "=") , prt 0 exp1 , doc (showString "in") , prt 0 exp])
- StoreE exp0 exp -> prPrec i 5 (concatD [prt 4 exp0 , doc (showString "<-") , prt 0 exp])
- CaseE exp casealts -> prPrec i 5 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 casealts , doc (showString "}")])
- BranchE branchalts -> prPrec i 5 (concatD [doc (showString "branch") , doc (showString "of") , doc (showString "{") , prt 0 branchalts , doc (showString "}")])
- BinOpE exp0 usym exp -> prPrec i 4 (concatD [prt 3 exp0 , prt 0 usym , prt 3 exp])
- AppE exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , prt 2 exp])
- UnOpE unop exp -> prPrec i 2 (concatD [prt 0 unop , prt 1 exp])
- IdxE exp0 exp -> prPrec i 1 (concatD [prt 1 exp0 , doc (showString "[") , prt 0 exp , doc (showString "]")])
- FldE exp field -> prPrec i 1 (concatD [prt 1 exp , doc (showString ".") , prt 0 field])
- ArrayE exps -> prPrec i 0 (concatD [doc (showString "Array") , doc (showString "[") , prt 0 exps , doc (showString "]")])
- RecordE fieldds -> prPrec i 0 (concatD [doc (showString "{") , prt 0 fieldds , doc (showString "}")])
- TupleE exps -> prPrec i 0 (concatD [doc (showString "(") , prt 0 exps , doc (showString ")")])
- AscribeE exp type' -> prPrec i 0 (concatD [doc (showString "(") , prt 0 exp , doc (showString "::") , prt 0 type' , doc (showString ")")])
- CountE count -> prPrec i 0 (concatD [prt 0 count])
- VarE var -> prPrec i 0 (concatD [prt 0 var])
- LitE lit -> prPrec i 0 (concatD [prt 0 lit])
-
- prtList es = case es of
- [] -> (concatD [])
- [x] -> (concatD [prt 0 x])
- [x] -> (concatD [prt 0 x])
- [x] -> (concatD [prt 5 x])
- x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
- x:xs -> (concatD [prt 0 x , prt 0 xs])
- x:xs -> (concatD [prt 5 x , doc (showString ";") , prt 5 xs])
-
-instance Print UnOp where
- prt i e = case e of
- Load -> prPrec i 0 (concatD [doc (showString "@")])
-
-
-instance Print CaseAlt where
- prt i e = case e of
- CaseAlt casepat exp -> prPrec i 0 (concatD [prt 0 casepat , doc (showString "->") , prt 0 exp])
-
- prtList es = case es of
- [x] -> (concatD [prt 0 x])
- x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
-
-instance Print CasePat where
- prt i e = case e of
- ConP con var -> prPrec i 0 (concatD [prt 0 con , prt 0 var])
- LitP lit -> prPrec i 0 (concatD [prt 0 lit])
- VarP var -> prPrec i 0 (concatD [prt 0 var])
-
-
-instance Print BranchAlt where
- prt i e = case e of
- BranchAlt branchpat exp -> prPrec i 0 (concatD [doc (showString "|") , prt 0 branchpat , doc (showString "->") , prt 0 exp])
-
- prtList es = case es of
- [x] -> (concatD [prt 0 x])
- x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
-
-instance Print BranchPat where
- prt i e = case e of
- BoolBP exp -> prPrec i 0 (concatD [prt 4 exp])
- DefaultBP -> prPrec i 0 (concatD [])
-
-
-instance Print Type where
- prt i e = case e of
- TyFun type'0 type' -> prPrec i 0 (concatD [prt 2 type'0 , doc (showString "->") , prt 0 type'])
- TyArray type'0 type' -> prPrec i 2 (concatD [doc (showString "Array") , prt 1 type'0 , prt 1 type'])
- TyConstr con types -> prPrec i 2 (concatD [prt 0 con , prt 1 types])
- TyTuple types -> prPrec i 0 (concatD [doc (showString "(") , prt 0 types , doc (showString ")")])
- TyCount count -> prPrec i 0 (concatD [prt 0 count])
- TyVarT tyvar -> prPrec i 0 (concatD [prt 0 tyvar])
- TyConstr0 con -> prPrec i 0 (concatD [prt 0 con])
-
- prtList es = case es of
- [] -> (concatD [])
- [] -> (concatD [])
- [x] -> (concatD [prt 0 x])
- [x] -> (concatD [prt 1 x])
- x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
- x:xs -> (concatD [prt 0 x , prt 0 xs])
- x:xs -> (concatD [prt 1 x , prt 1 xs])
-
-instance Print TyDecl where
- prt i e = case e of
- TyRecord fieldts -> prPrec i 0 (concatD [doc (showString "{") , prt 0 fieldts , doc (showString "}")])
- TyTagged concs -> prPrec i 0 (concatD [doc (showString "|") , prt 0 concs])
- TySyn type' -> prPrec i 0 (concatD [prt 0 type'])
-
-
-instance Print ConC where
- prt i e = case e of
- ConC con types -> prPrec i 0 (concatD [prt 0 con , prt 0 types])
-
- prtList es = case es of
- [x] -> (concatD [prt 0 x])
- x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
-
-instance Print FieldT where
- prt i e = case e of
- FieldT field type' -> prPrec i 0 (concatD [prt 0 field , doc (showString "::") , prt 0 type'])
-
- prtList es = case es of
- [] -> (concatD [])
- [x] -> (concatD [prt 0 x])
- x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
-
-instance Print Lit where
- prt i e = case e of
- CharL c -> prPrec i 0 (concatD [prt 0 c])
- StringL str -> prPrec i 0 (concatD [prt 0 str])
- IntL number -> prPrec i 0 (concatD [prt 0 number])
- FracL frac -> prPrec i 0 (concatD [prt 0 frac])
- EnumL con -> prPrec i 0 (concatD [prt 0 con])
-
-
-instance Print FieldD where
- prt i e = case e of
- FieldD field exp -> prPrec i 0 (concatD [prt 0 field , doc (showString "=") , prt 0 exp])
-
- prtList es = case es of
- [x] -> (concatD [prt 0 x])
- x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
-
-instance Print Var where
- prt i e = case e of
- Var lident -> prPrec i 0 (concatD [prt 0 lident])
-
-
-instance Print Con where
- prt i e = case e of
- Con uident -> prPrec i 0 (concatD [prt 0 uident])
-
-
-instance Print Modid where
- prt i e = case e of
- Modid uident -> prPrec i 0 (concatD [prt 0 uident])
-
-
-instance Print Field where
- prt i e = case e of
- Field lident -> prPrec i 0 (concatD [prt 0 lident])
-
-
-instance Print TyVar where
- prt i e = case e of
- VarTV lident -> prPrec i 0 (concatD [prt 0 lident])
- CntTV lident -> prPrec i 0 (concatD [doc (showString "#") , prt 0 lident])
-
- prtList es = case es of
- [] -> (concatD [])
- x:xs -> (concatD [prt 0 x , prt 0 xs])
-
-
diff --git a/Language/Pir/Abs.hs b/Language/Pir/Abs.hs
new file mode 100644
--- /dev/null
+++ b/Language/Pir/Abs.hs
@@ -0,0 +1,175 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module Language.Pir.Abs where
+import Control.DeepSeq
+import Data.Generics
+import Grm.Prims
+import Grm.Lex
+import Text.PrettyPrint.Leijen
+myLexemes = ["(",")",",","->","::",":=",";","=","alloca","call","cast","define","enum","if","import","load","module","noop","record","return","switch","tagged","when","while","{","|","}"]
+grmLexFilePath = lexFilePath myLexemes
+grmLexContents = lexContents myLexemes
+data Module
+ = Module Uident ImportList DefineList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Import
+ = Import Uident
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Define
+ = Define Type Lident TVarList StmtList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Stmt
+ = LetS TVar Exp
+ | StoreS TVar Atom
+ | CallS TVar AtomList
+ | SwitchS Atom StmtList SwitchAltList
+ | IfS Atom StmtList StmtList
+ | WhenS Atom StmtList
+ | WhileS StmtList Atom StmtList
+ | ReturnS Atom
+ | NoOpS
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Exp
+ = CallE TVar AtomList
+ | CastE TVar Type
+ | AllocaE Type
+ | LoadE TVar
+ | AtomE Atom
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Atom
+ = LitA TLit
+ | VarA TVar
+ deriving (Show,Eq,Ord,Data,Typeable)
+data SwitchAlt
+ = SwitchAlt TLit StmtList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Lit
+ = StringL String
+ | NmbrL Number
+ | CharL Char
+ | EnumL Uident
+ | VoidL
+ deriving (Show,Eq,Ord,Data,Typeable)
+data TyDecl
+ = TyEnum EnumCList
+ | TyRecord FieldTList
+ | TyTagged ConCList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data TVar
+ = TVar Lident Type
+ deriving (Show,Eq,Ord,Data,Typeable)
+data TLit
+ = TLit Lit Type
+ deriving (Show,Eq,Ord,Data,Typeable)
+data FieldT
+ = FieldT Uident Type
+ deriving (Show,Eq,Ord,Data,Typeable)
+data ConC
+ = ConC Uident Type
+ deriving (Show,Eq,Ord,Data,Typeable)
+data Type
+ = Type Uident TypeList
+ deriving (Show,Eq,Ord,Data,Typeable)
+data EnumC
+ = EnumC Uident
+ deriving (Show,Eq,Ord,Data,Typeable)
+type ConCList = [ConC ]
+type FieldTList = [FieldT ]
+type EnumCList = [EnumC ]
+type TypeList = [Type ]
+type ExpList = [Exp ]
+type AtomList = [Atom ]
+type TVarList = [TVar ]
+type SwitchAltList = [SwitchAlt ]
+type StmtList = [Stmt ]
+type DefineList = [Define ]
+type ImportList = [Import ]
+instance Pretty (Module ) where
+ pretty = ppModule
+ppModule x = case x of
+ Module v1 v2 v3 -> text "module" <+> ppUident v1 <+> ppImportList v2 <+> ppDefineList v3
+instance Pretty (Import ) where
+ pretty = ppImport
+ppImport x = case x of
+ Import v1 -> text "import" <+> ppUident v1
+instance Pretty (Define ) where
+ pretty = ppDefine
+ppDefine x = case x of
+ Define v1 v2 v3 v4 -> text "define" <+> ppType v1 <+> ppLident v2 <+> text "(" <+> ppTVarList v3 <+> text ")" <+> text "=" <+> text "{" <+> ppStmtList v4 <+> text "}"
+instance Pretty (Stmt ) where
+ pretty = ppStmt
+ppStmt x = case x of
+ LetS v1 v2 -> ppTVar v1 <+> text "=" <+> ppExp v2
+ StoreS v1 v2 -> ppTVar v1 <+> text ":=" <+> ppAtom v2
+ CallS v1 v2 -> text "call" <+> ppTVar v1 <+> text "(" <+> ppAtomList v2 <+> text ")"
+ SwitchS v1 v2 v3 -> text "switch" <+> ppAtom v1 <+> text "{" <+> ppStmtList v2 <+> text "}" <+> text "{" <+> ppSwitchAltList v3 <+> text "}"
+ IfS v1 v2 v3 -> text "if" <+> ppAtom v1 <+> text "{" <+> ppStmtList v2 <+> text "}" <+> text "{" <+> ppStmtList v3 <+> text "}"
+ WhenS v1 v2 -> text "when" <+> ppAtom v1 <+> text "{" <+> ppStmtList v2 <+> text "}"
+ WhileS v1 v2 v3 -> text "while" <+> text "{" <+> ppStmtList v1 <+> text "}" <+> ppAtom v2 <+> text "{" <+> ppStmtList v3 <+> text "}"
+ ReturnS v1 -> text "return" <+> ppAtom v1
+ NoOpS -> text "noop"
+instance Pretty (Exp ) where
+ pretty = ppExp
+ppExp x = case x of
+ CallE v1 v2 -> ppTVar v1 <+> text "(" <+> ppAtomList v2 <+> text ")"
+ CastE v1 v2 -> text "cast" <+> ppTVar v1 <+> ppType v2
+ AllocaE v1 -> text "alloca" <+> ppType v1
+ LoadE v1 -> text "load" <+> text "(" <+> ppTVar v1 <+> text ")"
+ AtomE v1 -> ppAtom v1
+instance Pretty (Atom ) where
+ pretty = ppAtom
+ppAtom x = case x of
+ LitA v1 -> ppTLit v1
+ VarA v1 -> ppTVar v1
+instance Pretty (SwitchAlt ) where
+ pretty = ppSwitchAlt
+ppSwitchAlt x = case x of
+ SwitchAlt v1 v2 -> ppTLit v1 <+> text "->" <+> text "{" <+> ppStmtList v2 <+> text "}"
+instance Pretty (Lit ) where
+ pretty = ppLit
+ppLit x = case x of
+ StringL v1 -> ppString v1
+ NmbrL v1 -> ppNumber v1
+ CharL v1 -> ppChar v1
+ EnumL v1 -> ppUident v1
+ VoidL -> Text.PrettyPrint.Leijen.empty
+instance Pretty (TyDecl ) where
+ pretty = ppTyDecl
+ppTyDecl x = case x of
+ TyEnum v1 -> text "enum" <+> ppEnumCList v1
+ TyRecord v1 -> text "record" <+> text "{" <+> ppFieldTList v1 <+> text "}"
+ TyTagged v1 -> text "tagged" <+> ppConCList v1
+instance Pretty (TVar ) where
+ pretty = ppTVar
+ppTVar x = case x of
+ TVar v1 v2 -> ppLident v1 <+> text "::" <+> ppType v2
+instance Pretty (TLit ) where
+ pretty = ppTLit
+ppTLit x = case x of
+ TLit v1 v2 -> ppLit v1 <+> text "::" <+> ppType v2
+instance Pretty (FieldT ) where
+ pretty = ppFieldT
+ppFieldT x = case x of
+ FieldT v1 v2 -> ppUident v1 <+> text "::" <+> ppType v2
+instance Pretty (ConC ) where
+ pretty = ppConC
+ppConC x = case x of
+ ConC v1 v2 -> ppUident v1 <+> ppType v2
+instance Pretty (Type ) where
+ pretty = ppType
+ppType x = case x of
+ Type v1 v2 -> ppUident v1 <+> text "(" <+> ppTypeList v2 <+> text ")"
+instance Pretty (EnumC ) where
+ pretty = ppEnumC
+ppEnumC x = case x of
+ EnumC v1 -> ppUident v1
+ppConCList = ppList ppConC Separator "|" Horiz
+ppFieldTList = ppList ppFieldT Separator "," Horiz
+ppEnumCList = ppList ppEnumC Separator "|" Horiz
+ppTypeList = ppList ppType Separator "," Horiz
+ppExpList = ppList ppExp Separator "," Horiz
+ppAtomList = ppList ppAtom Separator "," Horiz
+ppTVarList = ppList ppTVar Separator "," Horiz
+ppSwitchAltList = ppList ppSwitchAlt Terminator ";" Vert
+ppStmtList = ppList ppStmt Terminator ";" Vert
+ppDefineList = ppList ppDefine Terminator ";" Vert
+ppImportList = ppList ppImport Terminator ";" Vert
diff --git a/Main.hs b/Main.hs
deleted file mode 100644
--- a/Main.hs
+++ /dev/null
@@ -1,727 +0,0 @@
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-
--- The pec embedded compiler
--- Copyright 2011, Brett Letner
-
-module Main (main) where
-
-import Control.Monad.State
-import Data.Char
-import Data.Either
-import Data.List
-import Distribution.Text
-import GHC.IO.Exception
-import Language.Pec.Abs
-import Language.Pec.ErrM
-import Language.Pec.Layout
-import Language.Pec.Par
-import Language.Pec.Print
-import Paths_pec
-import System.Console.CmdArgs
-import System.Directory
-import System.FilePath
-import System.Process
-import qualified Language.Haskell as H
-
-data Args = Args
- { files :: [FilePath]
- , keep_tmp_files :: Bool
- , rebuild_all :: Bool
- , idir :: [FilePath]
- } deriving (Show, Data, Typeable)
-
-argsDesc :: Args
-argsDesc = Args
- { files = def &= args
- , keep_tmp_files = def &= help "Keep temporary files"
- , rebuild_all = def &= help "Rebuild all files"
- , idir = def &= typDir &= help "Import directory"
- } &= summary summry &= program prog
-
-summry :: String
-summry = prog ++ " v" ++ display version ++ ", " ++ copyright
-
-prog :: String
-prog = "pec"
-
-copyright :: String
-copyright = "(C) Brett Letner 2011"
-
-initSt :: Args -> IO St
-initSt x = do
- prel <- getDataFileName "lib/Prelude.pec"
- return $ St
- { visited = []
- , modified = False
- , rebuild = rebuild_all x
- , not_visited = map (\fn -> dropExtension fn ++ "_") $ files x
- , strings = []
- , counts = []
- , keep_tmps = keep_tmp_files x
- -- , mains = []
- , lib_dir = takeDirectory prel
- , imp_dirs = idir x
- }
-
-type M a = StateT St IO a
-
-data St = St
- { not_visited :: [FilePath]
- , modified :: Bool
- , rebuild :: Bool
- , visited :: [FilePath]
- , strings :: [String]
- , counts :: [Integer]
- , keep_tmps :: Bool
- , lib_dir :: FilePath
- , imp_dirs :: [FilePath]
--- , mains :: [FilePath]
- }
-
-main :: IO ()
-main = do
- args <- cmdArgs argsDesc
- let fns = files args
- st0 <- initSt args
- case fns of
- [] -> putStrLn summry
- (fn:_) -> do
- let mnFn = new_ext "_main.hs" fn
- let llFn = new_ext ".ll" fn
- st <- execStateT pec_all st0
- mnFnExists <- doesFileExist mnFn
- when (modified st || rebuild st || not mnFnExists) $ writeFile mnFn $ H.prettyPrint $
- hMainModule (dropExtension fn) (visited st) (strings st)
- my_system "runghc" ["-i" ++ concat (intersperse ":" $ all_imp_dirs st), mnFn]
- let llFns = ["istrings_" ++ new_ext ".ll" fn] ++ (map (new_ext ".ll" . init) $ visited st)
- let llBc = new_ext ".bc" llFn
- _ <- system $ "cat " ++ unwords llFns ++ " | llvm-as > " ++ llBc
- let llExe = new_ext ".exe" llFn
- my_system2 "llvm-ld" ["-disable-opt", "-native", "-o", llExe, llBc] -- array bug in llvm
- when (not $ keep_tmps st) $ my_system "rm" $
- [ "-f", "*.hi", "*.o", "*_.hs" -- fixme: clean up Cnts files
- , mnFn, llBc, new_ext ".exe.bc" fn
- ] ++ llFns
- return ()
-
-pec_all :: M ()
-pec_all = do
- st <- get
- case not_visited st of
- [] -> return ()
- (n:ns) -> do
- put $ st{ not_visited = ns }
- when (n `notElem` visited st) $ do
- ns <- pec_file n
- modify $ \st -> st{ visited = n : visited st
- , not_visited = ns ++ not_visited st
- }
- pec_all
-
-pec_file :: FilePath -> M [FilePath]
-pec_file n = do
- let fn0 = init n ++ ".pec"
- fn <- my_get_filepath fn0
- let hsFn = new_ext "_.hs" fn
- ss <- lift $ liftM lines $ readFile fn
- let (xs,ys) = partition (\s -> not (null s) && head s == '>') ss
- case pModule $ resolveLayout True $ myLexer $ unlines ys of
- Bad e -> error e
- Ok m -> do
- b <- isOutOfDate fn hsFn
- h <- hModule m
- when b $ do
- modify $ \st -> st{ modified = True }
- lift $ writeFile hsFn $ unlines $
- imports_hack (lines $ H.prettyPrint h) (map tail xs)
- return $ imports m
-
-all_imp_dirs :: St -> [String]
-all_imp_dirs st = ["."] ++ imp_dirs st ++ [lib_dir st]
-
-my_get_filepath :: FilePath -> M FilePath
-my_get_filepath fn = do
- xs <- gets all_imp_dirs
- lift $ get_filepath fn xs
-
-get_filepath :: FilePath -> [FilePath] -> IO FilePath
-get_filepath fn [] = error $ "unable to find file:" ++ fn
-get_filepath fn0 (x:xs) = do
- let fn = joinPath $ splitPath x ++ [fn0]
- r <- doesFileExist fn
- if r
- then return fn
- else get_filepath fn0 xs
-
-isOutOfDate :: FilePath -> FilePath -> M Bool
-isOutOfDate inFn outFn = do
- b <- gets rebuild
- if b
- then return True
- else do
- r <- lift $ doesFileExist outFn
- if r
- then liftM2 (>) (lift $ getModificationTime inFn) (lift $ getModificationTime outFn)
- else return True
-
-imports_hack :: [String] -> [String] -> [String]
-imports_hack xs ys
- | null es = bs ++ cs ++ ds
- | otherwise = bs ++ ds ++ fs ++ cs ++ gs
- where
- (bs,cs) = break (has_prefix "import ") xs
- (ds,es) = break (has_prefix "import ") ys
- (fs,gs) = span (has_prefix "import ") es
-
-doList :: [H.Exp] -> H.Exp
-doList xs =
- H.Do $ map H.Qualifier $ xs ++ [H.apps (H.var "return") [H.Tuple []]]
-
-importDecl :: Bool -> String -> H.ImportDecl
-importDecl q n = H.ImportDecl
- { H.importModule = H.ModuleName n
- , H.importQualified = q
- , H.importLoc = nl
- , H.importSrc = False
- , H.importPkg = Nothing
- , H.importAs = Nothing
- , H.importSpecs = Nothing
- }
-
-typeSig :: String -> H.Type -> H.Decl
-typeSig s = H.TypeSig nl [H.name s]
-
-gen :: Modid -> [TopDecl] -> [H.Decl]
-gen n xs =
- [ typeSig "gen" $ H.TyApp (H.tyCon "M") (H.TyTuple H.Boxed [])
- , H.bind "gen" [] $ H.apps (H.var "gen_file") [H.strE $ printTree n, doList $ concatMap f xs ]
- ]
- where
- f x = case x of
- ExternD _ a _ -> [H.apps (H.var "declare") [hvar a "d"]]
- ProcD a _ _ -> [H.apps (H.var "define") [hvar a "d"]]
- _ -> []
-
-hmodule :: String -> [String] -> Maybe [H.ExportSpec] -> [H.ImportDecl] -> [H.Decl] -> H.Module
-hmodule n ps = H.Module nl (H.ModuleName n)
- [H.LanguagePragma nl [H.name p] | p <- ps ] Nothing
-
-hMainModule :: FilePath -> [String] -> [String] -> H.Module
-hMainModule fn ns ss = hmodule "Main" [] Nothing imps [mainDecl]
- where
- imps = importDecl False "Pec.Base" : map (importDecl True) ns
- mainDecl = H.bind "main" [] $ H.apps (H.var "gen_files")
- [ H.strE fn
- , doList [H.qvar (H.ModuleName n) (H.name "gen") | n <- ns ]
- , H.List $ map H.strE $ nub $ sort ss
- ]
-
-filterCnts :: (Ord a, Num a) => [a] -> [a]
-filterCnts xs = filter (`notElem` [256, 4294967296]) $ nub $ sort xs
-
-hCountModule :: Integer -> M ()
-hCountModule i = do
- q <- gets rebuild
- r <- lift $ doesFileExist fn
- when (q || not r) $ do
- modify $ \st -> st{ modified = True }
- lift $ writeFile fn $ H.prettyPrint $ hmodule n [] Nothing
- [importDecl False "Pec.Base"]
- [ hdatadecl n [] [H.QualConDecl nl [] [] (H.ConDecl (H.name n) [])]
- , hinstdecl [] "Count" [H.tyCon n]
- [H.InsDecl $ H.simpleFun nl (H.name "countof") (H.name "_") (H.intE i)]
- , hinstdecl [] "Typed" [H.tyCon n]
- [H.InsDecl $ H.simpleFun nl (H.name "typeof") (H.name "_") (H.con "TyUnit")]
- ]
- where
- n = "Cnt" ++ show i
- fn = n ++ ".hs"
-
-hinstdecl :: H.Context -> String -> [H.Type] -> [H.InstDecl] -> H.Decl
-hinstdecl qs n = H.InstDecl nl (nub $ sort qs) (H.qname n)
-
-hModule :: Module -> M H.Module
-hModule (Module a b cs) = do
- (xs,ys) <- liftM partitionEithers $ mapM (hTopDecl n) cs
- cnts <- liftM filterCnts $ gets counts
- modify $ \st -> st{ counts = [] }
- mapM_ hCountModule cnts
- return $ hmodule n
- [ "FlexibleInstances", "MultiParamTypeClasses", "ScopedTypeVariables"
- , "TypeSynonymInstances" ]
- (hExpDecl a cs b)
- (importDecl False "Pec.Base" : [ importDecl False $ "Cnt" ++ show cnt | cnt <- cnts ] ++ xs)
- (gen a cs ++ concat ys)
- where n = userc a
-
-hExpDecl :: Modid -> [TopDecl] -> ExportDecl -> Maybe [H.ExportSpec]
-hExpDecl n xs a = case a of
- ExpAllD -> Nothing
- ExpListD bs -> Just $ (H.EVar $ H.Qual (H.ModuleName $ userc n) (H.name "gen")) : concatMap (hExport xs) bs
-
-hevar :: String -> H.ExportSpec
-hevar = H.EVar . H.qname
-
-hExport :: [TopDecl] -> Export -> [H.ExportSpec]
-hExport xs ex = case ex of
- VarEx a -> [hevar $ user a]
- TypeEx a b -> H.EThingWith (H.qname $ userc a) [] : map hevar zs
- where
- zs = case (lookupType xs a, b) of
- (_, Neither) -> []
- (TyTagged ys, Decon) -> concat $ map (tail . nPat) ys
- (TyTagged ys, Both) -> concatMap nPat ys
- (TyRecord ys, Both) -> map hgetfld ys
- _ -> error "export spec doesn't match type decl"
-
-lookupType :: Print a => [TopDecl] -> a -> TyDecl
-lookupType xs a = case [ b | TypeD a1 _ b <- xs, printTree a == printTree a1 ] of
- [] -> error $ "unknown type decl:" ++ printTree a
- (b:_) -> b
-
-hTopDecl :: String -> TopDecl -> M (Either H.ImportDecl [H.Decl])
-hTopDecl qn x = case x of
- VarD a b -> do
- e <- hExp b
- return $ Right [ nameBind (user a) e ]
- ProcD a bs c -> do
- e0 <- hExp c
- e1 <- foldM hArg e0 $ reverse bs
- return $ Right
- [ nameBind n $ H.App (H.var "call") (H.var nd)
- , nameBind nd $ H.apps (H.var "proc")
- [ H.strE $ init $ if n == "main_" then n else qn ++ "." ++ n
- , e1
- ]
- ]
- where
- n = user a
- nd = n ++ "d"
- ImportD a b -> case b of
- AsAS{} -> error "todo:'import as' not implemented"
- EmptyAS -> return $ Left $ importDecl False (userc a)
- ExternD a b c -> do
- t <- htype "Decl" c
- return $ Right
- [ nameBind (user b) $ H.App (H.var "call") (H.var nd)
- , nameBind nd $ ascribe (H.App (H.var "extern") (H.strE s)) t
- ]
- where
- s = case a of
- NoneNm -> printTree b
- SomeNm s -> s
- nd = user b ++ "d"
- AscribeD a b -> do
- t <- htype "Term" b
- return $ Right [typeSig (user a) t]
- TypeD a bs0 c -> do
- let bs = map uTyVar bs0
- let t0 = dtype_ty a bs
- case c of
- TySyn d -> do
- t <- pType d
- return $ Right
- [H.TypeDecl nl (H.name $ userc a) (map htvbind bs) t]
- TyRecord fs0 -> do
- let fs = sortBy cmpFieldT fs0
- Right ds <- hTopDecl qn $ TypeD a bs0 $ TyTagged [ConC a [ t | FieldT _ t <- fs ]]
- xs <- mapM (hfieldt t0 bs $ length fs) $ zip fs [0 .. ]
- return $ Right $ concat xs ++ ds
- TyTagged xs0 -> do
- let xs = sortBy (\(ConC a _) (ConC b _) -> compare a b) xs0
- let cnt = genericLength xs
- add_count cnt
- let dd = hdatadecl (userc a) (map htvbind bs) []
- cts <- sequence [ htytuple ts | ConC _ ts <- xs ]
- let rs = concatMap (fconc a bs cnt (isTyEnum xs)) $ zip (zip xs [0 .. ]) cts
- let typed_id e = hinstdecl (pre bs) "Typed" [t0] [ H.InsDecl $ nameBind "typeof" $ H.lamE nl [H.PParen $ H.PatTypeSig nl (H.PWildCard) t0 ] e ]
- return $ Right $ case () of
- () | isTyUnit xs ->
- let
- [ConC m _] = xs
- n = user m
- in
- [ dd
- , typed_id $ H.con "TyUnit"
- , typeSig n $ tpred bs $ tterm t0
- , nameBind n $ H.App (H.var "cast") (H.var "unit")
- , hinstdecl (hassts "EQ" bs) "EQ" [t0]
- [ H.InsDecl $ nameBind "eq" (H.var "eq_unit")
- , H.InsDecl $ nameBind "ne" (H.var "ne_unit") ]
- ]
- | isTyNewtype xs ->
- let
- [ct] = cts
- [ConC m _] = xs
- n = user m
- in
- [ dd
- , typed_id $ unused_ty ct
- , hinstdecl (hassts "Typed" bs) "Newtype" [t0, ct] []
- -- , hinstdecl (hassts "EQ" bs) "EQ" [t0]
- -- [ H.InsDecl $ nameBind "eq" (H.App (H.var "unwrap2") (H.var "eq"))
- -- , H.InsDecl $ nameBind "ne" (H.App (H.var "unwrap2") (H.var "ne")) ]
- , typeSig n $ tpred bs $ tterm $ H.TyFun ct t0
- , nameBind n $ H.var "wrap"
- ]
- | isTyEnum xs ->
- [ dd
- , typed_id $ H.App (H.con "TyEnum") (H.intE cnt)
- , hinstdecl (pre bs) "Tagged" [ t0, tcnt cnt ]
- [H.InsDecl $ nameBind "tagof" (H.var "cast")]
- , hinstdecl [] "EQ" [t0] []
- ] ++ rs
- | otherwise ->
- [ dd
- , typed_id $ H.App (H.con "TySum") (H.List [unused_ty ct | ct <- cts ])
- , hinstdecl (pre bs) "Tagged" [ tptr t0, tcnt cnt ]
- [H.InsDecl $ nameBind "tagof" (H.var "tagofp")]
- ] ++ rs
-
-hfieldt :: H.Type -> [TyVar] -> Int -> (FieldT, Int) -> M [H.Decl]
-hfieldt t0 tvs cnt (fld@(FieldT _ t), i) = do
- ht <- pType t
- return
- [ typeSig n $ tpred tvs $ H.TyFun (tterm $ tptr t0) (tterm $ tptr ht)
- , nameBind n $ foldr (\a b -> H.InfixApp (H.var $ a ++ "_get") (H.qvop ".") b) (H.App (H.var "app") (H.var "unwrap_ptr_")) ss
- ]
- where
- n = hgetfld fld
- ss = case cnt of
- 1 -> []
- _ | i == cnt - 1 -> replicate i "snd"
- _ -> ["fst"] ++ replicate i "snd"
-
-hgetfld :: FieldT -> String
-hgetfld (FieldT f _) = user f ++ "get"
-
-cmpFieldT :: FieldT -> FieldT -> Ordering
-cmpFieldT (FieldT a _) (FieldT b _) = compare a b
-
-cmpFieldD :: FieldD -> FieldD -> Ordering
-cmpFieldD (FieldD a _) (FieldD b _) = compare a b
-
-unused_ty :: H.Type -> H.Exp
-unused_ty t = H.App (H.var "typeof") $ ascribe (H.var "unused") t
-
-isTyUnit :: [ConC] -> Bool
-isTyUnit x = isTyNewtype x && isTyEnum x
-
-isTyNewtype :: [a] -> Bool
-isTyNewtype [_] = True
-isTyNewtype _ = False
-
-isTyEnum :: [ConC] -> Bool
-isTyEnum xs = and [ null ys | ConC _ ys <- xs ]
-
-hdatadecl :: String -> [H.TyVarBind] -> [H.QualConDecl] -> H.Decl
-hdatadecl n vs ds = H.DataDecl nl H.DataType [] (H.name n) vs ds []
-
-htycon :: Print a => a -> H.Type
-htycon = H.tyCon . userc
-
-htyvar :: TyVar -> H.Type
-htyvar = H.tyVar . printTree . uncnttv
-
-uncnttv :: TyVar -> Lident
-uncnttv x = case x of
- CntTV a -> a
- VarTV a -> a
-
-uTyVar :: TyVar -> TyVar
-uTyVar x = case x of
- CntTV a -> CntTV $ Lident $ user a
- VarTV a -> VarTV $ Lident $ user a
-
-pre :: [TyVar] -> [H.Asst]
-pre = map hasst
-
-hasst :: TyVar -> H.Asst
-hasst x = case x of
- CntTV{} -> H.ClassA (H.qname "Count") [htyvar x]
- VarTV{} -> H.ClassA (H.qname "Typed") [htyvar x]
-
-hassts :: String -> [TyVar] -> [H.Asst]
-hassts s tvs = [H.ClassA (H.qname s) [htyvar tv] | tv@VarTV{} <- tvs ] ++ map hasst tvs
-
-dtype_ty :: Print a => a -> [TyVar] -> H.Type
-dtype_ty a tvs = H.tyApps (htycon a) $ map htyvar tvs
-
-tptr :: H.Type -> H.Type
-tptr = H.TyApp (H.tyCon "Ptr")
-
-tcnt :: Show a => a -> H.Type
-tcnt cnt = H.tyCon $ "Cnt" ++ show cnt
-
-tpred :: [TyVar] -> H.Type -> H.Type
-tpred xs = H.TyForall Nothing (pre xs)
-
-tterm :: H.Type -> H.Type
-tterm = H.TyApp (H.tyCon "Term")
-
-fconc :: (Print a, Show a1) =>
- a
- -> [TyVar]
- -> a1
- -> Bool
- -> ((ConC, Integer), H.Type)
- -> [H.Decl]
-fconc a tvs cnt is_enm ((conc@(ConC _ ts), i),t1) =
- [ typeSig nTag $ tpred tvs $ tterm $ H.tyApps (H.tyCon "Tag") [mtptr t0, tcnt cnt]
- , nameBind nTag $ H.App (H.var "tag") (H.intE i)
- , typeSig n $ tpred tvs $ tterm $ if null ts then t0 else H.TyFun t1 t0
- , nameBind n $ H.App (H.var $ if is_enm then "cast" else if null ts then "constr0" else "constr") (H.var nTag)
- , typeSig nAlt $ tpred ((VarTV $ Lident "a") : tvs) $ H.TyFun (H.TyFun (tterm (mtptr t1)) (tterm ta)) $ H.TyFun (tterm (mtptr t0)) (tterm ta)
- , nameBind nAlt $ H.var $ if is_enm then "alt0" else "alt"
- ]
- where
- t0 = dtype_ty a tvs
- [n, nTag, nAlt] = nPat conc
- ta = H.tyVar "a"
- mtptr v = if is_enm then v else tptr v
-
-nPat :: ConC -> [String]
-nPat (ConC c _) = [n, n ++ "tag", n ++ "alt"]
- where
- n = user c
-
-hArg :: H.Exp -> Exp -> M H.Exp
-hArg e x = case x of
- VarE{} -> return $ H.apps (H.var "arg")
- [H.strE (printTree x), lambda [hpvar x] e]
- TupleE [] -> return $ H.App (H.var "unitarg") e
- TupleE [a] -> hArg e a
- _ -> do
- let v = varE "v"
- s <- hStmt $ LetS x v
- hArg (blocke [s, [H.Qualifier $ eval e]]) v
-
-ascribe :: H.Exp -> H.Type -> H.Exp
-ascribe a b = H.Paren $ H.ExpTypeSig nl a b
-
-nameBind :: String -> H.Exp -> H.Decl
-nameBind s = H.nameBind nl (H.name s)
-
-htype :: String -> Type -> M H.Type
-htype s = liftM (H.TyApp (H.tyCon s)) . pType
-
-pType :: Type -> M H.Type
-pType x = case x of
- TyConstr0{} -> return $ htycon x
- TyFun a b -> liftM2 H.TyFun (pType a) (pType b)
- TyTuple xs -> htytuple xs
- TyConstr a bs -> liftM (H.tyApps (htycon a)) $ mapM pType bs
- TyArray a b -> liftM (H.tyApps (H.tyCon "Array")) $ mapM pType [a,b]
- TyCount a -> add_count i >> return (tcnt i)
- where i = pcount a
- TyVarT a -> return $ H.tyVar $ user a
-
-htytuple :: [Type] -> M H.Type
-htytuple xs0 = case xs0 of
- [] -> return $ tytuple []
- [a] -> pType a
- [a,b] -> liftM tytuple $ mapM pType [a,b]
- (x:xs) -> liftM tytuple $ mapM pType [x, TyTuple xs]
-
-htvbind :: TyVar -> H.TyVarBind
-htvbind = H.UnkindedVar . H.name . printTree . uncnttv
-
-pcount :: Count -> Integer
-pcount = read . tail . printTree
-
-tytuple :: [H.Type] -> H.Type
-tytuple = H.TyTuple H.Boxed
-
-lambda :: [H.Pat] -> H.Exp -> H.Exp
-lambda = H.Lambda nl
-
-hpvar :: Print a => a -> H.Pat
-hpvar = H.pVar . user
-
-hvar :: Print a => a -> String -> H.Exp
-hvar a s = H.var $ user a ++ s
-
-hCaseAlt :: CaseAlt -> M H.Exp
-hCaseAlt (CaseAlt p x) = do
- e <- hExp x
- case p of
- VarP{} -> return $ H.tuple [ H.var "defaulttag", lambda [hpvar p] e]
- ConP a b -> return $ H.tuple
- [ H.var $ s ++ "tag"
- , H.App (H.var $ s ++ "alt") (lambda [hpvar b] e)
- ]
- where s = user a
- LitP y -> case y of
- EnumL a -> hCaseAlt (CaseAlt (ConP a (var "_")) x)
- IntL a -> f "int" (H.Paren $ H.Lit $ H.Int $ read $ printTree a)
- StringL a -> add_string a >> f "string" (H.Lit $ H.String a)
- CharL a -> f "char" (H.Lit $ H.Char a)
- FracL{} -> error $ "can't case on fractional:" ++ printTree y
- where
- f s t = return $ H.tuple [ H.App (H.var $ s ++ "tag") t
- , lambda [H.wildcard] e]
-
-eval :: H.Exp -> H.Exp
-eval e = H.App (H.var "eval") e
-
-hStmt :: Exp -> M [H.Stmt]
-hStmt x = case x of
- LetS a b -> case a of
- VarE{} -> do
- e <- hExp b
- return [H.Generator nl (hpvar a) $ eval e]
- TupleE xs0 -> case xs0 of
- [] -> do
- e <- hExp b
- t <- htype "Term" $ TyTuple []
- return [H.Qualifier $ eval $ ascribe e t]
- [e] -> hStmt $ LetS e b
- [ea,eb] -> liftM concat $ mapM hStmt
- [ LetS e b
- , LetS ea $ AppE (varE "fst") e
- , LetS eb $ AppE (varE "snd") e
- ] where e = varE "pat"
- (x:xs) -> hStmt $ LetS (TupleE [x, TupleE xs]) b
- AscribeE e t -> hStmt $ LetS e $ AscribeE b t
- _ -> error $ "unexpected pattern:" ++ printTree x
- _ -> do
- e <- hExp x
- return [H.Qualifier $ eval e]
-
-varE :: String -> Exp
-varE = VarE . var
-
-var :: String -> Var
-var = Var . Lident
-
-con :: String -> Con
-con = Con . Uident
-
-blocke :: [[H.Stmt]] -> H.Exp
-blocke = H.App (H.var "lift") . H.Do . concat
-
-enuml :: String -> Lit
-enuml = EnumL . con
-
-penum :: String -> CasePat
-penum = LitP . enuml
-
-hExp :: Exp -> M H.Exp
-hExp x = case x of
- RecordE xs -> hExp $ BlockE $
- [ LetS p $ varE "alloca'" ] ++
- [ StoreE (FldE p a) b | FieldD a b <- sortBy cmpFieldD xs ] ++
- [ UnOpE Load p ]
- where p = varE "p"
- BlockE xs -> liftM blocke $ mapM hStmt xs
- LetS{} -> error "let stmt must be inside of do block"
- LetE a b c -> hExp $ BlockE [LetS a b, c]
- BranchE bs0 -> case bs0 of
- (BranchAlt (BoolBP f) g : bs) | not $ null bs -> hExp $ CaseE f
- [ CaseAlt (penum "True") g
- , CaseAlt (penum "False") $ BranchE bs
- ]
- [BranchAlt DefaultBP g] -> hExp g
- _ -> error "malformed branch expression"
- CaseE a bs -> do
- e <- hExp a
- cs <- mapM hCaseAlt bs
- return $ H.apps (H.var "switch") [ e, H.List cs ]
- StoreE a b -> do
- ea <- hExp a
- eb <- hExp b
- return $ H.apps (H.var "store") [ea, eb]
- AppE a b -> do
- ea <- hExp a
- eb <- hExp b
- return $ H.apps (H.var "app") [ea, eb]
- BinOpE a b c -> do
- ea <- hExp a
- ec <- hExp c
- return $ H.Paren $ H.InfixApp ea (H.qvop $ eSym $ printTree b) ec
- UnOpE a b ->
- liftM (H.App (H.Paren $ H.var $ eSym $ printTree a)) $ hExp b
- IdxE a b -> do
- ea <- hExp a
- eb <- hExp b
- return $ H.apps (H.var "idx") [ea,eb]
- FldE a b -> liftM (H.App (hvar b "get")) $ hExp a
- ArrayE xs -> do
- e <- hExp $ CountE (Count $ '#' : show (length xs))
- es <- mapM hExp xs
- return $ H.apps (H.var "array") [ e, H.List es ]
- TupleE xs0 -> case xs0 of
- [] -> return $ H.var "unit"
- [a] -> hExp a
- [a,b] -> do
- ea <- hExp a
- eb <- hExp b
- return $ H.apps (H.var "pair") [ea,eb]
- (x:xs) -> hExp $ TupleE [x, TupleE xs]
- AscribeE a b -> liftM2 ascribe (hExp a) (htype "Term" b)
- CountE a -> do
- add_count i
- return $ ascribe (H.var "unused") $
- H.TyApp (H.tyCon "Term") (H.tyCon $ "Cnt" ++ show i)
- where i = pcount a
- VarE a -> return $ hvar a ""
- LitE a -> hLit a
-
-nl :: H.SrcLoc
-nl = error "SRCLOC"
-
-add_string :: String -> M ()
-add_string s = modify $ \st -> st{ strings = s : strings st }
-
-add_count :: Integer -> M ()
-add_count s = modify $ \st -> st{ counts = s : counts st }
-
-eSym :: String -> String
-eSym cs = cs ++ "$"
-
-hLit :: Lit -> M H.Exp
-hLit x = case x of
- EnumL a -> return $ H.var $ user a
- CharL a -> return $ H.App (H.var "char") $ H.Lit $ H.Char a
- IntL a -> return $ H.App (H.var "int") $ H.Paren $ H.Lit $ H.Int $ read $ printTree a
- StringL a -> do
- add_string a
- return (H.App (H.var "string") $ H.Lit $ H.String a)
- FracL a -> return $ H.App (H.var "frac") $ H.Paren $ H.Lit $ H.Frac $ toRational $ ((read $ printTree a) :: Double)
-
-lowercase :: String -> String
-lowercase "" = ""
-lowercase (c:cs) = toLower c : cs
-
-has_prefix :: Eq a => [a] -> [a] -> Bool
-has_prefix pre s = take (length pre) s == pre
-
-new_ext :: String -> FilePath -> FilePath
-new_ext s fn = dropExtension fn ++ s
-
-imports :: Module -> [String]
-imports (Module _ _ xs) = [ userc a | ImportD a _ <- xs ]
-
-user :: Print a => a -> String
-user = lowercase . userc
-
-userc :: Print a => a -> String
-userc a = printTree a ++ "_"
-
-my_system :: String -> [String] -> IO ()
-my_system s ss = do
- putStrLn $ "system:" ++ unwords (s:ss)
- ec <- rawSystem s ss
- case ec of
- ExitSuccess -> return ()
- ExitFailure i -> error $ "exiting(" ++ show i ++ ")"
-
-my_system2 :: String -> [String] -> IO ()
-my_system2 s ss = do
- let cmd = unwords (s:ss)
- putStrLn $ "system:" ++ cmd
- ec <- system cmd
- case ec of
- ExitSuccess -> return ()
- ExitFailure i -> error $ "exiting(" ++ show i ++ ")"
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -1,45 +1,4 @@
-all : config install tests # cov
- wc -l Main.hs Pec/Base.hs
-
-install : build
- ./Setup.exe install
-
-tests :
- (cd test_cases;make)
-
-build : Setup.exe # config
- ./Setup.exe build
-
-config : ./Setup.exe
- ./Setup.exe configure --user
-
-EXCLUDE=--exclude=Language.Pec.Print --exclude=Language.Pec.Abs --exclude=Language.Pec.Par --exclude=Language.Pec.Lex --exclude=Language.Pec.ErrM --exclude=Language.Pec.Layout
-
-cov :
- mv test_cases/*.tix .
- hpc markup pec $(EXCLUDE)
- hpc report pec $(EXCLUDE)
-
-Setup.exe : Setup.hs
- ghc --make -o $@ $<
-
-gen : Language/Pec/Par.hs Language/Pec/Lex.hs
-
-Language/%/Par.y Language/%/Lex.x : %.cf
- bnfc -p Language -d $<
-
-Language/%/Par.hs : Language/%/Par.y
- happy $<
-
-Language/%/Lex.hs : Language/%/Lex.x
- alex $<
-
-clean :
- rm -f *.bc *.ll *.exe *.o *.hi *.y *.s *.out *~ *.tix hpc_*.html *.hs.html *~
- (cd test_cases;make clean)
- (cd Pec;make clean)
- rm -rf dist .hpc pec-0.1
-
-vclean : clean
- (cd test_cases;make vclean)
- rm -rf Language
+all :
+ runghc MkPec.hs
+# (cd test_cases;time pec clean *.pec) # builds C targets
+# (cd test_cases;time pec clean --march=LLVM *.pec) # builds LLVM targets
diff --git a/MkPec.hs b/MkPec.hs
new file mode 100644
--- /dev/null
+++ b/MkPec.hs
@@ -0,0 +1,124 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- The pec embedded compiler
+-- Copyright 2011-2012, Brett Letner
+
+module Main(main) where
+
+import Control.Monad
+import Data.Maybe
+import Development.Shake
+import Development.Shake.FilePath
+import System.Console.CmdArgs
+import System.Directory
+
+data Args = Args
+ { targets :: [String]
+ } deriving (Show, Data, Typeable)
+
+copyright :: String
+copyright = "(C) Brett Letner 2011-2012"
+
+version :: String
+version = "0.0.1"
+
+argsDesc :: Args
+argsDesc = Args
+ { targets = def &= args
+ } &= summary summry &= program prog
+
+summry :: String
+summry = prog ++ " v" ++ version ++ ", " ++ copyright
+
+prog :: String
+prog = "MkPec.exe"
+
+src_files :: [String]
+src_files =
+ [ "Pec/Base.hs"
+ , "Pec/C.hs"
+ , "Pec/LLVM.hs"
+ , "Pec/Desugar.hs"
+ , "Pec/IUtil.hs"
+ , "Pec/HUtil.hs"
+ , "Pec/PUtil.hs"
+ , "src/Pec.hs"
+ , "src/PecGen.hs"
+ , "src/PecGenCnt.hs"
+ , "lib/Prelude.pec"
+ , "lib/Data/Stack.pec"
+ , "lib/Data/Array.pec"
+ , "lib/Data/Deque.pec"
+ , "lib/Data/Queue.pec"
+ , "lib/Data/StrBuf.pec"
+ ]
+
+gen_files :: [String]
+gen_files =
+ [ "Language/Pec/Abs.hs"
+ , "Language/Pec/Par.hs"
+ , "Language/Pec/Par.y"
+ , "Language/Pds/Abs.hs"
+ , "Language/Pir/Abs.hs"
+ , "Language/C/Abs.hs"
+ , "Language/LLVM/Abs.hs"
+ ]
+
+clean :: IO ()
+clean = mapM_ rmrf ["dist",".hpc","pec-0.2.0"]
+
+whenHasExe :: String -> Action () -> Action ()
+whenHasExe exe f = do
+ ma <- liftIO $ findExecutable exe
+ when (isJust ma) f
+
+main :: IO ()
+main = do
+ a <- cmdArgs argsDesc
+
+ let setup = "runhaskell"
+
+ when ("clean" `elem` targets a) clean
+
+ when ("vclean" `elem` targets a) $ do
+ clean
+ rmrf "Language"
+
+ shake shakeOptions $ do
+ want ["dist/build/autogen/Paths_pec.hs"]
+
+ "Language/*/Par.y" *> \fnOut -> do
+ need [ dropFileName fnOut ++ "Abs.hs" ]
+
+ "Language/*/Abs.hs" *> \fnOut -> do
+ let fn = grammar fnOut ++ ".grm"
+ need [fn]
+ whenHasExe "grm" $ if fn == "Pec.grm"
+ then system' "grm" [fn, "--locations"]
+ else system' "grm" [fn]
+
+ "Language/*/Par.hs" *> \parOut -> do
+ let fn = takeDirectory parOut "Par.y"
+ need [fn]
+ whenHasExe "happy" $ system' "happy" ["-o", parOut, fn]
+
+ "dist/setup-config" *> \_ -> do
+ need $ src_files ++ gen_files
+ need ["pec.cabal", "Setup.hs"]
+ system' setup ["Setup.hs", "configure", "--user"]
+
+ "dist/build/autogen/Paths_pec.hs" *> \_ -> do
+ need ["dist/setup-config"]
+ system' setup ["Setup.hs", "build"]
+ system' setup ["Setup.hs", "install"]
+
+grammar :: FilePath -> String
+grammar fn = case splitDirectories fn of
+ "Language":x:_ -> x
+ _ -> error $ "unable to determine grammar name from filename:" ++ fn
+
+rmrf :: FilePath -> IO ()
+rmrf fn = do
+ r <- doesDirectoryExist fn
+ when r $ removeDirectoryRecursive fn
diff --git a/Pds.grm b/Pds.grm
new file mode 100644
--- /dev/null
+++ b/Pds.grm
@@ -0,0 +1,78 @@
+data Module
+ | Module "module" uident "{" ExportDList ImportDList TypeDList InstDList VarDList "}"
+
+data ExportD
+ | TypeEx "export" uident
+ | VarEx "export" lident
+
+data ImportD | ImportD "import" uident AsSpec
+
+data AsSpec
+ | AsAS "as" uident
+ | EmptyAS
+
+data TypeD | TypeD "type" uident VarList "=" TyDecl
+data VarD | VarD lident DeclSym Exp
+data InstD | InstD "instance" uident Type
+
+data DeclSym
+ | Macro "=>"
+ | Define "="
+
+data TyDecl
+ | TyRecord "record" "{" FieldTList "}"
+ | TyTagged "tagged" ConCList
+ | TyEnum "enum" EnumCList
+ | TySyn "synonym" Type
+ | TyNewtype "newtype" uident Type
+ | TyUnit "unit" uident
+
+data Exp
+ | LetE "let" lident DeclSym Exp "in" Exp
+ | LamE "\\" lident "->" Exp
+ | SwitchE "switch" Exp "of" Default "{" SwitchAltList "}"
+ | AppE "(" Exp Exp ")"
+ | AscribeE "(" Exp "::" Type ")"
+ | VarE lident
+ | LitE Lit
+
+data Default
+ | DefaultNone
+ | DefaultSome Exp
+
+data Lit
+ | CharL char
+ | StringL string
+ | NmbrL number
+
+data Type
+ | TyCxt "{" CxtList "}" "=>" Type
+ | TyFun "(" Type "->" Type ")"
+ | TyVoid "VoidT"
+ | TyConstr "(" uident TypeList ")"
+ | TyVarT lident
+
+data SwitchAlt | SwitchAlt Exp "->" Exp
+
+data Cxt | Cxt uident VarList
+
+data ConC | ConC uident Type
+
+data EnumC | EnumC uident
+
+data FieldT | FieldT uident "::" Type
+
+data Var | Var lident
+
+list ExportDList ExportD empty terminator ";" vert
+list ImportDList ImportD empty terminator ";" vert
+list VarDList VarD empty terminator ";" vert
+list TypeDList TypeD empty terminator ";" vert
+list InstDList InstD empty terminator ";" vert
+list SwitchAltList SwitchAlt empty terminator ";" vert
+list EnumCList EnumC nonempty separator "|" horiz
+list ConCList ConC nonempty separator "|" horiz
+list FieldTList FieldT nonempty separator "," horiz
+list VarList Var empty separator "" horiz
+list TypeList Type empty separator "" horiz
+list CxtList Cxt nonempty separator "," horiz
diff --git a/Pec.cf b/Pec.cf
deleted file mode 100644
--- a/Pec.cf
+++ /dev/null
@@ -1,136 +0,0 @@
-comment "//";
-comment "/*" "*/";
-
-entrypoints Module;
-
-layout "where", "do", "of";
-
-Module . Module ::= "module" Modid "exports" ExportDecl "where" "{" [TopDecl] "}";
-
-ExpAllD . ExportDecl ::= "all";
-ExpListD . ExportDecl ::= "(" [Export] ")";
-
-TypeEx . Export ::= Con Spec;
-VarEx . Export ::= Var;
-
-Neither . Spec ::= ;
-Decon . Spec ::= "(" "." ")";
-Both . Spec ::= "(" ".." ")";
-
-ImportD . TopDecl ::= "import" Modid AsSpec;
-ExternD . TopDecl ::= "extern" ExtNm Var "::" Type;
-TypeD . TopDecl ::= "type" Con [TyVar] "=" TyDecl;
-AscribeD . TopDecl ::= Var "::" Type;
-VarD . TopDecl ::= Var "=" Exp;
-ProcD . TopDecl ::= Var [Exp0] "=" Exp;
-
-AsAS . AsSpec ::= "as" Con ;
-EmptyAS . AsSpec ::= ;
-
-SomeNm . ExtNm ::= String;
-NoneNm . ExtNm ::= ;
-
-BlockE . Exp ::= "do" "{" [Exp5] "}";
-_ . Exp ::= Exp5;
-
-LetS . Exp5 ::= Exp4 "=" Exp; -- sugar which can only appear in a block and lhs only var
-LetE . Exp5 ::= "let" Exp4 "=" Exp "in" Exp;
-StoreE . Exp5 ::= Exp4 "<-" Exp;
-CaseE . Exp5 ::= "case" Exp "of" "{" [CaseAlt] "}";
-BranchE . Exp5 ::= "branch" "of" "{" [BranchAlt] "}";
-_ . Exp5 ::= Exp4;
-
-BinOpE . Exp4 ::= Exp3 USym Exp3;
-_ . Exp4 ::= Exp3;
-
-AppE . Exp3 ::= Exp3 Exp2;
-_ . Exp3 ::= Exp2;
-
-UnOpE . Exp2 ::= UnOp Exp1;
-_ . Exp2 ::= Exp1;
-
-IdxE . Exp1 ::= Exp1 "[" Exp "]";
-FldE . Exp1 ::= Exp1 "." Field;
-_ . Exp1 ::= Exp0;
-
-ArrayE . Exp0 ::= "Array" "[" [Exp] "]";
-RecordE . Exp0 ::= "{" [FieldD] "}";
-TupleE . Exp0 ::= "(" [Exp] ")";
-AscribeE . Exp0 ::= "(" Exp "::" Type ")";
-CountE . Exp0 ::= Count;
-VarE . Exp0 ::= Var;
-LitE . Exp0 ::= Lit;
-
-Load . UnOp ::= "@";
-
-CaseAlt . CaseAlt ::= CasePat "->" Exp;
-
-ConP . CasePat ::= Con Var;
-LitP . CasePat ::= Lit;
-VarP . CasePat ::= Var;
-
-BranchAlt . BranchAlt ::= "|" BranchPat "->" Exp;
-
-BoolBP . BranchPat ::= Exp4;
-DefaultBP . BranchPat ::= ;
-
-TyFun . Type ::= Type2 "->" Type;
-_ . Type ::= Type2;
-
-TyArray . Type2 ::= "Array" Type1 Type1;
-TyConstr . Type2 ::= Con [Type1];
-_ . Type2 ::= Type1;
-
-_ . Type1 ::= Type0;
-
-TyTuple . Type0 ::= "(" [Type] ")";
-TyCount . Type0 ::= Count;
-TyVarT . Type0 ::= TyVar;
-TyConstr0 . Type0 ::= Con;
-
-TyRecord . TyDecl ::= "{" [FieldT] "}";
-TyTagged . TyDecl ::= "|" [ConC];
-TySyn . TyDecl ::= Type;
-
-ConC . ConC ::= Con [Type0];
-
-FieldT . FieldT ::= Field "::" Type;
-
-CharL . Lit ::= Char;
-StringL . Lit ::= String;
-IntL . Lit ::= Number;
-FracL . Lit ::= Frac;
-EnumL . Lit ::= Con;
-
-FieldD . FieldD ::= Field "=" Exp;
-
-Var . Var ::= Lident;
-Con . Con ::= Uident;
-Modid . Modid ::= Uident;
-
-Field . Field ::= Lident;
-VarTV . TyVar ::= Lident;
-CntTV . TyVar ::= "#" Lident;
-
-token Frac ('-'? digit+ '.' digit+ ('e' '-'? digit+)?);
-
-token Uident (upper (letter | digit | '_')*);
-token Lident ((lower | '_') (letter | digit | '_')*);
-token USym (('!' | '#' | '$' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '\\' | '^' | '|' | '~')+);
-token Number ('-'? digit+);
-token Count ('#' digit+);
-
-separator Exp ",";
-separator FieldT ",";
-separator TyVar "";
-separator Type ",";
-separator Export ",";
-separator Type0 "";
-separator nonempty ConC "|";
-separator nonempty Exp0 "";
-separator nonempty FieldD ",";
-separator nonempty Type1 "";
-separator TopDecl ";";
-separator nonempty CaseAlt ";";
-separator nonempty BranchAlt ";";
-separator nonempty Exp5 ";";
diff --git a/Pec.grm b/Pec.grm
new file mode 100644
--- /dev/null
+++ b/Pec.grm
@@ -0,0 +1,175 @@
+data Module
+ | Module "module" Modid ExportDecls ImportDecls "where" "{" TopDeclList "}"
+
+data ExportDecls
+ | ExpListD "exports" "{" ExportList "}"
+ | ExpAllD
+
+data ImportDecls
+ | ImpListD "imports" "{" ImportList "}"
+ | ImpNoneD
+
+data Export
+ | TypeEx Con Spec
+ | VarEx Var
+
+data Import | Import Modid AsSpec
+
+data AsSpec
+ | AsAS "as" Modid
+ | EmptyAS
+
+data Spec
+ | Neither
+ | Decon "(" "." ")"
+ | Both "(" ".." ")"
+
+data TopDecl
+ | ExternD "extern" ExtNm Var "::" Type
+ | TypeD "type" Con VarList "=" TyDecl
+ | TypeD0 "type" Con VarList
+ | AscribeD Var "::" Type
+ | VarD Var DeclSym Exp
+ | ProcD Var Exp0List DeclSym Exp
+ | InstD "instance" Con Type
+
+data DeclSym
+ | Macro "=>"
+ | Define "="
+
+data ExtNm
+ | SomeNm string
+ | NoneNm
+
+group {
+
+data Exp
+ | BlockE "do" "{" Exp5List "}"
+ | _ Exp5
+
+data Exp5
+ | LetS Exp4 DeclSym Exp -- sugar which can only appear in a block and lhs only var
+ | LetE "let" Exp4 DeclSym Exp "in" Exp
+ | LamE "\\" Exp0List "->" Exp
+ | StoreE Exp4 "<-" Exp
+ | CaseE "case" Exp "of" "{" CaseAltList DefaultAlt "}"
+ | SwitchE "switch" Exp "of" "{" SwitchAltList DefaultAlt "}"
+ | BranchE "branch" "{" BranchAltList "|" Exp ";" "}"
+ | _ Exp4
+
+data Exp4
+ | BinOpE Exp3 usym Exp3
+ | _ Exp3
+
+data Exp3
+ | AppE Exp3 Exp2
+ | _ Exp2
+
+data Exp2
+ | UnOpE UnOp Exp1
+ | _ Exp1
+
+data Exp1
+ | IdxE Exp1 "[" Exp "]"
+ | FldE Exp1 "." Field
+ | _ Exp0
+
+data Exp0
+ | ArrayE "Array" "[" ExpList "]"
+ | RecordE "{" FieldDList "}"
+ | TupleE "(" ExpList ")"
+ | AscribeE "(" Exp "::" Type ")"
+ | CountE Count
+ | VarE Var
+ | LitE Lit
+
+}
+
+data UnOp | Load "@"
+
+data CaseAlt | CaseAlt Con VarList "->" Exp
+
+data SwitchAlt | SwitchAlt Lit "->" Exp
+
+data DefaultAlt
+ | DefaultAlt Var "->" Exp ";"
+ | DefaultNone
+
+data BranchAlt | BranchAlt Exp4 "->" Exp
+
+data Cxt | Cxt Con VarList
+
+group {
+
+data Type
+ | TyCxt "{" CxtList "}" "=>" Type3
+ | _ Type3
+
+data Type3
+ | TyFun Type2 "->" Type3
+ | _ Type2
+
+data Type2
+ | TyArray "Array" Type1 Type1
+ | TyConstr Con Type1List
+ | _ Type1
+
+data Type1
+ | _ Type0
+
+data Type0
+ | TyTuple "(" TypeList ")"
+ | TyCount Count
+ | TyVarT TyVar
+ | TyConstr0 Con
+
+}
+
+data TyDecl
+ | TyRecord "{" FieldTList "}"
+ | TyTagged "|" ConCList
+ | TySyn Type
+
+data ConC | ConC Con Type0List
+
+data FieldT | FieldT Field "::" Type
+
+data Lit
+ | CharL char
+ | StringL string
+ | NmbrL number
+ | EnumL Con
+
+data FieldD | FieldD Field "=" Exp
+
+data Count | Count "#" "" number
+
+data Var | Var lident
+
+data Con | Con uident
+
+data Modid | Modid uident
+
+data Field | Field lident
+
+data TyVar
+ | VarTV lident
+ | CntTV "#" lident
+
+list BranchAltList BranchAlt empty terminator ";" vert
+list CaseAltList CaseAlt empty terminator ";" vert
+list SwitchAltList SwitchAlt empty terminator ";" vert
+list TopDeclList TopDecl empty terminator ";" vert
+list ImportList Import nonempty terminator ";" vert
+list Exp5List Exp5 nonempty terminator ";" vert
+list ExportList Export nonempty terminator ";" vert
+list ConCList ConC nonempty separator "|" horiz
+list Exp0List Exp0 nonempty separator "" horiz
+list VarList Var empty separator "" horiz
+list ExpList Exp empty separator "," horiz
+list FieldDList FieldD nonempty separator "," horiz
+list FieldTList FieldT nonempty separator "," horiz
+list Type0List Type0 empty separator "" horiz
+list Type1List Type1 nonempty separator "" horiz
+list TypeList Type3 empty separator "," horiz
+list CxtList Cxt nonempty separator "," horiz
diff --git a/Pec/Base.hs b/Pec/Base.hs
--- a/Pec/Base.hs
+++ b/Pec/Base.hs
@@ -1,599 +1,708 @@
{-# OPTIONS -Wall #-}
-{-# LANGUAGE EmptyDataDecls, MultiParamTypeClasses #-}
-{-# LANGUAGE FunctionalDependencies, FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, GADTs #-}
-
--- The pec embedded compiler
--- Copyright 2011, Brett Letner
-
-module Pec.Base
-
-where
-
-import Control.Monad
-import Control.Monad.State hiding (lift)
-import Data.Char
-import Data.List
-import Data.Unique
-import Numeric
-import System.IO
-import qualified Control.Monad.State as S
-
-data V a = V String
-data Decl a = Decl Id (Term a)
-data Ptr a
-data Tag a cnt
-data Idx cnt
-data Array cnt a
-data I cnt
-data IString
-data W cnt
-data Cnt256 = Cnt256
-data Cnt4294967296 = Cnt4294967296
-data SuccCnt cnt
-
-data Term a where
- Arg :: (Typed a, Typed b) => Id -> (Term a -> Term b) -> Term (a -> b)
- Val :: Typed a => V a -> Term a
- App :: (Typed a, Typed b) => Term (a -> b) -> Term a -> Term b
- Lift :: Typed a => M (Term a) -> Term a
-
-data Ty
- = TyUnit
- | TyEnum Integer
- | TyPtr Ty
- | TyArray Integer Ty
- | TyPair Ty Ty
- | TySum [Ty]
- | TyFun Ty Ty
- | TyDouble
- | TyFloat
- deriving Eq
-
-data St = St
- { istrings_tbl :: [String]
- , outH :: Handle
- , last_label :: Label
- }
-
-type CntW32 = Cnt4294967296
-type W32 = W CntW32
-type Label = String
-type M a = StateT St IO a
-type Id = String
-type CString = Ptr Char
-type W_ a = W a
-type I_ a = I a
-type SuccCnt_ a = SuccCnt a
-
-class Count cnt where countof :: cnt -> Integer
-
-instance Count cnt => Count (SuccCnt cnt) where
- countof _ = succ $ countof (unused :: cnt)
-
-class (Count cnt, Typed a) => Tagged a cnt | a -> cnt where
- tagof :: Term a -> Term (Tag a cnt)
-
-class Typed a where
- typeof :: a -> Ty
- callt :: Id -> [(Id,Ty)] -> Term a
- callt n bs = with_local $ \(v :: V a) -> do
- let t = typeof (unused :: a)
- let pre = if is_tyunit t then [] else [vof v ++ " ="]
- out 2 $ pre ++ ["call", tyof t, n ++ args (reverse bs)]
-
-class (Typed a, Typed b) => Newtype a b | a -> b where
- unwrap_ :: Term (a -> b)
- unwrap_ = wrap
-
- unwrap_ptr_ :: Term (Ptr a -> Ptr b)
- unwrap_ptr_ = lam_ cast
-
-class INT a where int :: Integer -> Term a
-
-instance Count Cnt256 where countof _ = 256
-instance Count Cnt4294967296 where countof _ = 4294967296
-instance Count cnt => INT (I cnt) where int = sint unused
-instance Count cnt => INT (Idx cnt) where int = uint unused
-instance Count cnt => INT (W cnt) where int = uint unused
-instance Count cnt => Tagged (I cnt) cnt where tagof = cast
-instance Count cnt => Tagged (W cnt) cnt where tagof = cast
-instance Tagged Char Cnt256 where tagof = cast
-instance Tagged IString CntW32 where tagof = cast
-instance Typed () where typeof _ = TyUnit
-instance Typed Char where typeof _ = TyEnum 256
-instance Typed Double where typeof _ = TyDouble
-instance Typed Float where typeof _ = TyFloat
-instance Typed IString where typeof _ = TyEnum $ countof (unused :: CntW32)
-
-instance Count cnt => Typed (SuccCnt cnt) where typeof _ = TyUnit
-
-instance Typed a => Typed (Ptr a) where
- typeof (_ :: Ptr a) = TyPtr $ typeof (unused :: a)
-
-instance (Typed a, Count cnt) => Typed (Array cnt a) where
- typeof (_ :: Array cnt a) =
- TyArray (countof (unused :: cnt)) (typeof (unused :: a))
-
-instance (Typed a, Typed b) => Typed (a -> b) where
- typeof (_ :: a -> b) =
- TyFun (typeof (unused :: a)) (typeof (unused :: b))
-
- callt n bs = Arg n $ \a -> Lift $ do
- V s <- evalv a
- return $ callt n ((s, typeof (unused :: a)) : bs)
-
-instance (Typed a, Typed b) => Typed (a, b) where
- typeof (_ :: (a, b)) =
- TyPair (typeof (unused :: a)) (typeof (unused :: b))
-
-instance Count cnt => Typed (I cnt) where
- typeof (_ :: I cnt) = TyEnum (countof (unused :: cnt))
-
-instance Count cnt => Typed (W cnt) where
- typeof (_ :: W cnt) = TyEnum (countof (unused :: cnt))
-
-instance Count cnt => Typed (Idx cnt) where
- typeof (_ :: Idx cnt) = TyEnum (countof (unused :: cnt))
-
-instance (Typed a, Count cnt) => Typed (Tag a cnt) where
- typeof (_ :: Tag a cnt) = TyEnum $ countof (unused :: cnt)
-
-uint :: (Count cnt, Typed (f cnt)) => f cnt -> Integer -> Term (f cnt)
-uint (_ :: f cnt) x
- | x >= 0 && x < countof (unused :: cnt) = tag x
- | otherwise = error $ "unsigned integer out of range:" ++ show x
-
-sint :: (Count cnt, Typed (f cnt)) => f cnt -> Integer -> Term (f cnt)
-sint (_ :: f cnt) x
- | x >= -y && x < y = tag x
- | otherwise = error $ "signed integer out of range:" ++ show x
- where
- y = countof (unused :: cnt) `div` 2
-
-wrap :: (Typed a, Typed b) => Term (a -> b)
-wrap = lam_ cast
-
-unwrap2 :: (Newtype a b, Typed c) =>
- (Term b -> Term b -> Term c) -> Term a -> Term a -> Term c
-unwrap2 f = \a b -> f (app unwrap_ a) (app unwrap_ b)
-
-unused :: a
-unused = error "unused"
-
-cast :: (Typed a, Typed b) => Term a -> Term b
-cast f = Lift $ do
- V a <- evalv f
- return $ val a
-
-tagofp :: (Typed a, Count cnt) => Term (Ptr a) -> Term (Tag (Ptr a) cnt)
-tagofp = load . tagp
-
-alt0 :: (Typed a, Typed b) => (Term () -> Term b) -> Term a -> Term b
-alt0 f _ = f unit
-
-alt :: (Typed a, Typed b, Typed c) =>
- (Term (Ptr b) -> Term c) -> Term (Ptr a) -> Term c
-alt f = f . datap
-
-constr :: (Typed a, Count cnt, Typed b) =>
- Term (Tag (Ptr a) cnt) -> Term (b -> a)
-constr tg = lam_ $ \f -> Lift $ do
- p <- eval $ alloca unused
- eval_ $ store (tagp p) tg
- eval_ $ store (datap p) f
- return $ load p
-
-constr0 :: (Typed a, Count cnt) => Term (Tag (Ptr a) cnt) -> Term a
-constr0 tg = Lift $ do
- p <- eval $ alloca unused
- eval_ $ store (tagp p) tg
- return $ load p
-
-tagp :: (Typed a, Count cnt) =>
- Term (Ptr a) -> Term (Ptr (Tag (Ptr a) cnt))
-tagp = gep (tag 0 :: Term W32)
-
-datap :: (Typed a, Typed b) => Term (Ptr a) -> Term (Ptr b)
-datap (f :: Term (Ptr a)) = with_local $ \r -> do
- p <- evalv f
- q <- new_local
- let TySum ts = typeof (unused :: a)
- out 2 [ vof q, "= getelementptr", vtof p ++ ", i32 0, i32 1" ]
- out 2 [ vof r, "= bitcast", tyof $ TyPtr $ max_tysum ts, vof q
- , "to", tof r ]
-
-bitcast :: (Typed a, Typed b) => Term (Ptr a) -> Term (Ptr b)
-bitcast x = with_local $ \q -> do
- p <- evalv x
- out 2 [ vof q, "= bitcast", vtof p, "to", tof q ]
-
-gep :: (Typed a, Typed b) => Term i -> Term (Ptr a) -> Term (Ptr b)
-gep f g = with_local $ \q -> do
- i <- evalv f
- p <- evalv g
- out 2 [ vof q, "= getelementptr", vtof p ++ ", i32 0, i32", vof i ]
-
-load :: Typed a => Term (Ptr a) -> Term a
-load f = with_local $ \v -> do
- p <- evalv f
- out 2 [ vof v, "= load", vtof p ]
-
-prim2 :: (Typed a, Typed b, Typed c) =>
- String -> Term a -> Term b -> Term c
-prim2 s f g = with_local $ \c -> do
- a <- evalv f
- b <- evalv g
- out 2 [ vof c, "=", s, vtof a ++ ",", vof b ]
-
-tag :: Typed a => Integer -> Term a
-tag = val . show
-
-store :: Typed a => Term (Ptr a) -> Term a -> Term ()
-store f g = Lift $ do
- p <- evalv f
- a <- evalv g
- out 2 [ "store", vtof a ++ ",", vtof p ]
- return unit
-
-pair :: (Typed a, Typed b) => Term a -> Term b -> Term (a,b)
-pair f g = Lift $ do
- p <- eval $ alloca unused
- eval_ $ store (fst_get p) f
- eval_ $ store (snd_get p) g
- return $ load p
-
-fst_get :: (Typed a, Typed b) => Term (Ptr (a,b)) -> Term (Ptr a)
-fst_get = gep (tag 0 :: Term W32)
-
-snd_get :: (Typed a, Typed b) => Term (Ptr (a,b)) -> Term (Ptr b)
-snd_get = gep (tag 1 :: Term W32)
-
-fst_ :: (Typed a, Typed b) => Term (Ptr (a,b) -> Ptr a)
-fst_ = lam_ fst_get
-
-snd_ :: (Typed a, Typed b) => Term (Ptr (a,b) -> Ptr b)
-snd_ = lam_ snd_get
-
-array :: (Count cnt, Typed a) => Term cnt -> [Term a] -> Term (Array cnt a)
-array _ xs = Lift $ do
- p <- eval $ alloca unused
- sequence_ [ eval $ store (idx p (int i)) x | (i,x) <- zip [0 .. ] xs ]
- return $ load p
-
-new_ :: Typed a => Term (a -> Ptr a)
-new_ = lam_ new
-
-alloca :: Typed a => Term a -> Term (Ptr a)
-alloca (_ :: Term a) = with_local $ \p -> do
- out 2 [ vof p, "= alloca", tof (unused :: V a) ]
-
-alloca'_ :: Typed a => Term (Ptr a)
-alloca'_= alloca unused
-
-new :: Typed a => Term a -> Term (Ptr a)
-new f = Lift $ do
- p <- eval $ alloca f
- eval_ $ store p f
- return p
-
-lam3_ :: (Typed a, Typed b, Typed c, Typed d) =>
- (Term a -> Term b -> Term c -> Term d) -> Term (a -> b -> c -> d)
-lam3_ f = lam_ $ \x -> lam_ $ \y -> lam_ $ \z -> f x y z
-
-lam2_ :: (Typed a, Typed b, Typed c) =>
- (Term a -> Term b -> Term c) -> Term (a -> b -> c)
-lam2_ f = lam_ $ \x -> lam_ $ \y -> f x y
-
-app3 :: (Typed a, Typed b, Typed c, Typed d) =>
- Term (a -> b -> c -> d) -> Term a -> Term b -> Term c -> Term d
-app3 f a b = app (app2 f a b)
-
-app2 :: (Typed a, Typed b, Typed c) =>
- Term (a -> b -> c) -> Term a -> Term b -> Term c
-app2 f = app . app f
-
-arg :: (Typed a, Typed b) => Id -> (Term a -> Term b) -> Term (a -> b)
-arg s = Arg ("%" ++ s)
-
-unitarg :: Typed a => Term a -> Term (() -> a)
-unitarg x = arg (error "UNITLAM") (\_ -> x)
-
-args :: [(Id,Ty)] -> String
-args xs = parens $ commaSep $ map (\(s,t) -> tyof t ++ " " ++ s) $
- filter (not . is_tyunit . snd) xs
-
-parens :: String -> String
-parens s = "(" ++ s ++ ")"
-
-argsof :: Typed a => Term a -> [(Id,Ty)]
-argsof (x :: Term a) = case x of
- Arg s (f :: Term b -> Term c) ->
- (s, typeof (unused :: b)) : argsof (f (unused :: Term b))
- _ -> [(error "ARGSOF", typeof (unused :: a))]
-
-define :: Typed a => Decl a -> M ()
-define (Decl n a) = do
- out 0 ["define", tyof $ snd $ last xs, n ++ args (init xs) ]
- out 2 ["{"]
- loop a
- out 2 ["}"]
- where
- xs = argsof a
- loop :: Typed a => Term a -> M ()
- loop (x :: Term a) = case x of
- Arg s f -> loop (f $ val s)
- _ -> do
- v <- evalv x
- out 2 [ "ret"
- , if is_tyunit (typeof (unused :: a)) then "void" else vtof v
- ]
-
-switch :: (Tagged a cnt, Typed b) =>
- Term a -> [(Term (Tag a cnt), Term a -> Term b)] -> Term b
-switch a bs = Lift $ do
- v <- eval a
- tg <- evalv $ tagof v
- ls <- sequence $ replicate (length bs) new_label
- out 2 [ "switch", vtof tg ++ ",", lblof (last ls) ]
- out 4 ["["]
- let zs = zip bs ls
- sequence_
- [ do u <- evalv t
- out 4 [commaSep [vtof u, lblof l]]
- | ((t,_),l) <- init zs
- ]
- out 4 ["]"]
- done <- new_label
- cs <- mapM (eval_alt v done) zs
- lblout done
- return $ phi cs
-
-phi :: Typed a => [(V a, Label)] -> Term a
-phi xs = with_local $ \(v :: V a) ->
- when (not $ is_tyunit $ typeof (unused :: a)) $
- out 2 [ vof v, "= phi", tof v, commaSep $ map phi_arg xs ]
-
-phi_arg :: Typed a => (V a, Label) -> String
-phi_arg (x,l) = brackets (vof x ++ ", %" ++ l)
-
-brackets :: String -> String
-brackets s = "[" ++ s ++ "]"
-
-eval_alt :: (Typed a, Typed b) =>
- Term a -> Label -> ((z, Term a -> Term b), Label) -> M (V b, Label)
-eval_alt a done ((_,f),l) = do
- lblout l
- v <- evalv $ f a
- out 2 [ "br", lblof done ]
- m <- gets last_label
- return (v,m)
-
-lblout :: Label -> M ()
-lblout l = do
- out 0 [l ++ ":"]
- modify $ \st -> st{ last_label = l }
-
-lblof :: Label -> String
-lblof l = "label %" ++ l
-
-from_istring_ :: Term (IString -> CString) -- todo:should return immutable cstring
-from_istring_ = lam_ $ \f -> with_local $ \s -> do
- i <- evalv f
- p :: V (Ptr CString) <- new_local
- xs <- gets istrings_tbl
- out 2 [ vof p, "= getelementptr [" ++ show (length xs)
- , " x i8*]* @.istrings, i32 0,", vtof i
- ]
- out 2 [ vof s, "= load", vtof p]
-
-app :: (Typed a, Typed b) => Term (a -> b) -> Term a -> Term b
-app = App
-
-evalv :: Term a -> M (V a)
-evalv x = case x of
- Arg a _ -> return $ V a
- Val a -> return a
- _ -> reduce x >>= evalv
-
-reduce :: Term a -> M (Term a)
-reduce x = case x of
- App f a -> case f of
- Arg _ g -> return $ g a
- Val (V n) -> reduce $ App (callt n []) a
- _ -> reduce f >>= \v -> return (App v a)
- Lift f -> f
- _ -> return x
-
-val :: Typed a => String -> Term a
-val = Val . V
-
-is_tyunit :: Ty -> Bool
-is_tyunit x = x == TyUnit
-
-tof :: Typed a => V a -> String
-tof (_ :: V a) = tyof $ typeof (unused :: a)
-
-proc :: Typed a => Id -> Term a -> Decl a
-proc a = Decl ("@" ++ a)
-
-lift :: Typed a => M (Term a) -> Term a
-lift = Lift
-
-extern :: Typed a => Id -> Decl a
-extern n = Decl ("@" ++ n) unused
-
-gen_files :: FilePath -> M () -> [String] -> IO ()
-gen_files fn f ss = evalStateT (f >> gen_istrings fn) (St ss (error "gen_files:outH") "")
-
-gen_file :: FilePath -> M () -> M ()
-gen_file fn f = do
- h <- S.lift $ openFile outFn WriteMode
- modify $ \st -> st{ outH = h }
- () <- f
- modify $ \st -> st{ outH = error "outH" }
- S.lift $ hClose h
- where
- outFn = fn ++ ".ll"
-
-gen_istrings :: FilePath -> M ()
-gen_istrings fn = gen_file ("istrings_" ++ fn) $ do
- xs <- gets istrings_tbl
- when (not $ null xs) $ do
- let ys = [ ("@.istr" ++ show i, cs, show $ length cs + 1)
- | (i,cs) <- zip [0 :: Int .. ] xs ]
- mapM_ f ys
- out 0 ["@.istrings = global [" ++ show (length ys) ++ " x i8*]"]
- out 2 ["["]
- mapM_ (g ",") (init ys)
- g "" (last ys)
- out 2 ["]"]
- where
- f (i,s,n) =
- out 0 [i, "= private constant [" ++ n ++ " x i8]", const_cstring s ]
- g s (i,_,n) =
- out 2 [ "i8* getelementptr ([" ++ n, "x i8]*"
- , i ++ ", i32 0, i32 0)" ++ s]
-
-string :: String -> Term IString
-string s = Lift $ do
- xs <- gets istrings_tbl
- case elemIndex s xs of
- Just i -> return $ tag $ fromIntegral i
- Nothing -> error "STRING"
-
-tyof :: Ty -> String
-tyof x = case x of
- TyEnum{} -> "i" ++ show (sizeof x)
- TyUnit -> "void"
- TyPtr a -> tyof a ++ "*"
- TyPair a b -> "{" ++ tyof a ++ ", " ++ tyof b ++ "}"
- TyArray i a -> brackets $ show i ++ " x " ++ tyof a
- TySum xs -> tyof $ ty_sum xs
- TyDouble -> "double"
- TyFloat -> "float"
- TyFun{} -> (tyof $ last xs) ++ parens (commaSep $ map tyof $ init xs) ++ "*"
- where xs = unfold_tyfun x
-
-unfold_tyfun :: Ty -> [Ty]
-unfold_tyfun x = case x of
- TyFun a b -> a : unfold_tyfun b
- _ -> [x]
-
-ty_sum :: [Ty] -> Ty
-ty_sum xs = TyPair (TyEnum $ genericLength xs) $ max_tysum xs
-
-max_tysum :: [Ty] -> Ty
-max_tysum = maximumBy (\a b -> compare (sizeof a) (sizeof b))
-
-sizeofptr :: Integer
-sizeofptr = 32 -- fixme:non-portable
-
-idx :: (Count cnt, Typed a) =>
- Term (Ptr (Array cnt a)) -> Term (Idx cnt) -> Term (Ptr a)
-idx = flip gep
-
-sizeof :: Ty -> Integer
-sizeof x = case x of
- TyEnum i -> bitsToEncode i
- TyUnit -> 0
- TyPtr{} -> sizeofptr
- TyPair a b -> sizeof a + sizeof b
- TyFun{} -> sizeofptr
- TyArray i a -> i * sizeof a
- TySum xs -> sizeof $ ty_sum xs
- TyDouble -> 64
- TyFloat -> 32
-
-char :: Char -> Term Char
-char = tag . fromIntegral . ord
-
-eval :: Typed a => Term a -> M (Term a)
-eval = liftM Val . evalv
-
-eval_ :: Typed a => Term a -> M ()
-eval_ x = eval x >> return ()
-
-lam_ :: (Typed a, Typed b) => (Term a -> Term b) -> Term (a -> b)
-lam_ = Arg (error "lam")
-
-with_local :: Typed a => (V a -> M ()) -> Term a
-with_local f = Lift $ do
- v <- new_local
- f v
- return $ Val v
-
-vof :: V a -> String
-vof (V v) = v
-
-vtof :: Typed a => V a -> String
-vtof a = unwords [tof a, vof a]
-
-out :: Int -> [String] -> M ()
-out i xs = do
- h <- gets outH
- S.lift $ hPutStrLn h $ replicate i ' ' ++ unwords xs
-
-new_local :: M (V a)
-new_local = liftM (V . (++) "%v") $ S.lift freshNm
-
-new_label :: M Label
-new_label = liftM ((++) "LBL") $ S.lift freshNm
-
-unit :: Term ()
-unit = val $ error "UNIT"
-
-call :: Typed a => Decl a -> Term a
-call (Decl n _) = callt n []
-
-declare :: Typed a => Decl a -> M ()
-declare (Decl n (_ :: Term a)) =
- out 0 ["declare", tyof $ last xs, n ++ args_ (init xs) ]
- where
- xs = loop (typeof (unused :: a))
- loop t = case t of
- TyFun a b -> [a] ++ loop b
- _ -> [t]
-
-args_ :: [Ty] -> String
-args_ xs = parens $ commaSep $ map tyof $ filter (not . is_tyunit) xs
-
-const_cstring :: String -> String
-const_cstring s = "c\"" ++ concatMap const_char s ++ "\\00\""
-
-const_char :: Char -> String
-const_char c
- | c < ' ' || c > '~' || c == '\\' = encode_char c
- | otherwise = [c]
-
-encode_char :: Enum a => a -> String
-encode_char c =
- '\\' : (if i <= 0xf then "0" else "") ++ map toUpper (showHex i "")
- where i = fromEnum c
-
-bitsToEncode :: Integer -> Integer
-bitsToEncode 0 = 0
-bitsToEncode i = ceiling $ logBase 2 (fromIntegral i :: Double)
-
-freshNm :: IO String
-freshNm = liftM (show . hashUnique) newUnique
-
-commaSep :: [String] -> String
-commaSep = concat . intersperse ", "
-
-inttag :: (INT a, Typed a, Count cnt) => Integer -> Term (Tag a cnt)
-inttag = inttagt unused
-
-inttagt :: (INT a, Typed a, Count cnt) => a -> Integer -> Term (Tag a cnt)
-inttagt (_ :: a) i = Lift $ do
- V s :: V a <- evalv (int i)
- return $ val s
-
-chartag :: Char -> Term (Tag Char Cnt256)
-chartag = cast . char
-
-stringtag :: String -> Term (Tag IString CntW32)
-stringtag = cast . string
-
-defaulttag :: Tagged a cnt => Term (Tag a cnt)
-defaulttag = val $ error "DEFAULT"
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- The pec embedded compiler
+-- Copyright 2011-2012, Brett Letner
+
+module Pec.Base
+( module Pec.Base
+, module Language.Pir.Abs
+, unused
+)
+
+where
+
+import Control.Concurrent
+import Control.Monad.State
+import Data.Data
+import Data.Generics.Uniplate.Data
+import Data.List
+import Development.Shake.FilePath
+import Distribution.Text
+import Grm.Prims
+import Language.Pir.Abs hiding (Exp(..))
+import Paths_pec
+import Pec.C
+import Pec.IUtil (vtvar, gTyDecls)
+import Pec.PUtil
+import Prelude hiding (exp)
+import System.Console.CmdArgs hiding (atom)
+import System.IO.Unsafe
+import qualified Language.Pir.Abs as I
+import qualified Pec.LLVM as L
+
+data Args = Args
+ { march :: Arch
+ , readable :: Bool
+ } deriving (Show, Data, Typeable)
+
+argsDesc :: Args
+argsDesc = Args
+ { march = def &= help "arch to build (C or LLVM)"
+ , readable = def &= help "generate human readable C (experimental)"
+ } &= summary summry &= program prog
+
+summry :: String
+summry = prog ++ " v" ++ display version ++ ", " ++ copyright
+
+prog :: String
+prog = "pecgen"
+
+data E a = E Exp deriving Show
+
+unE :: Typed a => E a -> Exp
+unE = f (error "unused:unE")
+ where
+ f :: Typed a => a -> E a -> Exp
+ f a (E x) = seq (addGTyDecls $ tydecls a) x
+
+setE :: Typed a => Exp -> E a
+setE = f (error "unused:setE")
+ where
+ f :: Typed a => a -> Exp -> E a
+ f a x = seq (addGTyDecls $ tydecls a) $ E x
+
+data Exp
+ = VarE TVar
+ | AppE Exp Exp
+ | SwitchE Exp Exp [(Exp,Exp)]
+ | LitE TLit
+ | LetE TVar Exp Exp
+ | LamE TVar (Exp -> Exp)
+ | DefE TVar Exp
+
+instance Show Exp where -- for debugging
+ show x = case x of
+ VarE a -> unwords ["VarE", show a]
+ AppE a b -> unwords ["AppE", show a, show b]
+ SwitchE a b c -> unwords ["SwitchE", show a, show b, show c]
+ LitE a -> unwords ["LitE", show a]
+ LetE a b c -> unwords ["LetE", show a, show b, show c]
+ LamE a _ -> unwords ["LamE", show a]
+ DefE a b -> unwords ["DefE", show a, show b]
+
+apps :: [Exp] -> Exp
+apps = foldl1 AppE
+
+type M a = State St a
+
+data St = St
+ { stmts :: [Stmt]
+ }
+
+tatom :: Atom -> Type
+tatom x = case x of
+ VarA (TVar _ a) -> a
+ LitA (TLit _ a) -> a
+
+isVoidA :: Atom -> Bool
+isVoidA = isVoidTy . tatom
+
+isVoidE :: I.Exp -> Bool
+isVoidE = isVoidTy . texp
+
+isVoidV :: TVar -> Bool
+isVoidV = isVoidTy . ttvar
+
+fNoOpS :: [Stmt] -> Maybe [Stmt]
+fNoOpS xs | any ((==) NoOpS) xs = Just $ filter ((/=) NoOpS) xs
+fNoOpS _ = Nothing
+
+fVoidS :: Stmt -> Maybe Stmt
+fVoidS (ReturnS (LitA (TLit VoidL _))) = Nothing
+fVoidS (ReturnS a) | isVoidA a = Just $ ReturnS voidA
+fVoidS (LetS _ b) | isVoidE b = case b of
+ I.CallE a bs -> Just $ CallS a bs
+ _ -> Just NoOpS
+fVoidS (CallS a bs) | any isVoidA bs =
+ Just $ CallS a $ filter (not . isVoidA) bs
+ -- ^ type of a is no longer correct (it may contain void types)
+fVoidS (StoreS _ b) | isVoidA b = Just NoOpS
+fVoidS _ = Nothing
+
+fVoidE :: I.Exp -> Maybe I.Exp
+fVoidE (I.CallE a bs) | any isVoidA bs =
+ Just $ I.CallE a $ filter (not . isVoidA) bs
+ -- ^ type of a is no longer correct (it may contain void types)
+fVoidE _ = Nothing
+
+fVoidD :: Define -> Maybe Define
+fVoidD (Define a b cs ds) | any isVoidV cs =
+ Just $ Define a b (filter (not . isVoidV) cs) ds
+fVoidD _ = Nothing
+
+texp :: I.Exp -> Type
+texp x = case x of
+ I.CastE _ b -> b
+ I.AllocaE a -> tyPtr a
+ I.AtomE a -> tatom a
+ I.LoadE a -> unTyPtr $ ttvar a
+ I.CallE a bs -> tcall (ttvar a) $ map tatom bs
+
+tcall :: Type -> [Type] -> Type
+tcall a bs = case splitAt (length ts) bs of
+ (_,[]) -> t
+ (_,cs) -> tcall t cs
+ where (t,ts) = unFunTy a
+
+tyRecord :: [(String,Type)] -> TyDecl
+tyRecord xs = TyRecord [ FieldT a b | (a,b) <- xs]
+
+tyEnum :: [String] -> TyDecl
+tyEnum bs = TyEnum $ map EnumC bs
+
+initSt :: St
+initSt = St{ stmts = [] }
+
+stmt :: Stmt -> M ()
+stmt x = modify $ \st -> st{ stmts = x : stmts st }
+
+pop_block :: M [Stmt]
+pop_block = do
+ ss0 <- gets stmts
+ modify $ \st -> st{ stmts = [] }
+ return $ reverse ss0
+
+push_block :: [Stmt] -> M ()
+push_block x = modify $ \st -> st{ stmts = reverse x ++ stmts st }
+
+block :: (Exp -> M a) -> Exp -> M (a,[Stmt])
+block f a = do
+ ss0 <- pop_block
+ x <- f a
+ ss1 <- pop_block
+ push_block ss0
+ return (x,ss1)
+
+block_ :: (Exp -> M Atom) -> Exp -> M [Stmt]
+block_ f a = liftM snd $ block f a
+
+assignAtom :: I.Exp -> M Atom
+assignAtom x = do
+ v <- fresh (texp x)
+ stmt $ LetS v x
+ return $ VarA v
+
+ifSwitchS :: Atom -> [Stmt] -> [SwitchAlt] -> M [Stmt]
+ifSwitchS _ ys [] = return ys
+ifSwitchS x ys (SwitchAlt a bs : zs) = do
+ ss <- ifSwitchS x ys zs
+ v <- assignAtom $ I.CallE strEqE [x, LitA a]
+ return [IfS v bs ss]
+
+strEqE :: TVar
+strEqE = TVar "eq" $ tyFun tyIString (tyFun tyIString tyBool)
+
+ttvar :: TVar -> Type
+ttvar (TVar _ b) = b
+
+atom :: Exp -> M Atom
+atom x = case x of
+ VarE a -> return $ VarA a
+ LitE a -> return $ LitA a
+ DefE a _ -> return $ VarA a
+ _ -> expr x >>= assignAtom
+
+tvar :: Exp -> M TVar
+tvar x = do
+ a <- atom x
+ case a of
+ VarA v -> return v
+ _ -> error $ "expected variable:" ++ ppShow a
+
+exprFun :: Type -> Exp -> [Exp] -> M I.Exp
+exprFun t y ys = do
+ v <- tvar y
+ case (v,ys) of
+ (TVar "load" _, [a]) -> liftM I.LoadE $ tvar a
+ (TVar "then" _, [a, b]) -> do
+ ss <- block_ atom a
+ push_block ss
+ expr b
+ (TVar "if" _, [a, b, c]) -> do
+ r <- fresh (tyPtr t)
+ stmt $ LetS r $ I.AllocaE t
+ e <- atom a
+ bb <- block_ (store r) b
+ bc <- block_ (store r) c
+ stmt $ IfS e bb bc
+ return $ I.LoadE r
+ (TVar "unsafe_cast" _, [a]) -> do
+ e <- atom a
+ case e of
+ LitA (TLit l _) -> return $ I.AtomE $ LitA $ TLit l t
+ VarA b -> return $ I.CastE b t
+ (TVar "when" _, [a, b]) -> do
+ e <- atom a
+ bb <- block_ atom b
+ stmt $ WhenS e bb
+ return voidE
+ (TVar "while" _, [a, b]) -> do
+ (e,aa) <- block atom a
+ bb <- block_ atom b
+ stmt $ WhileS aa e bb
+ return voidE
+ (TVar "store" _, [a, b]) -> do
+ r <- tvar a
+ e <- atom b
+ stmt $ StoreS r e
+ return voidE
+ _ -> do
+ es <- mapM atom ys
+ return $ I.CallE v es
+
+unApp :: Exp -> [Exp]
+unApp x = case x of
+ AppE a b -> unApp a ++ [b]
+ _ -> [x]
+
+unFunTy :: Type -> (Type, [Type])
+unFunTy x = case x of
+ Type "Fun_" ts -> (last ts, init ts)
+ _ -> error $ "function type expected:" ++ ppShow x
+
+expr :: Exp -> M I.Exp
+expr x = case x of
+ DefE a _ -> case a of
+ TVar "unsafe_alloca" t -> return $ I.AllocaE (unTyPtr t)
+ _ -> return $ I.AtomE $ VarA a
+ VarE a -> return $ I.AtomE $ VarA a
+ LitE{} -> liftM I.AtomE $ atom x
+ AppE{} -> do
+ let (y:ys) = unApp x
+ let (_,ts) = unFunTy $ tof y
+ case splitAt (length ts) ys of
+ (bs,[])
+ | length bs < length ts ->
+ error $ "no partial application:" ++ show x
+ | otherwise -> exprFun (tof x) y ys
+ (bs,cs) -> do
+ let e = apps (y:bs)
+ v <- fresh (tof e)
+ expr $ LetE v e (apps (VarE v : cs))
+ SwitchE a b cs -> do
+ let t = tof b
+ v <- fresh $ tyPtr t
+ stmt $ LetS v $ I.AllocaE t
+ e <- atom a
+ dflt <- block_ (store v) b
+ alts <- mapM (alt v) cs
+ if tof a == tyIString
+ then ifSwitchS e dflt alts >>= mapM_ stmt -- will have void type
+ else stmt $ SwitchS e dflt alts
+ return $ I.LoadE v
+ LetE a b c -> do
+ e <- expr b
+ stmt $ LetS a e
+ expr c
+ LamE{} -> error "unapplied lamda expression"
+
+alt :: TVar -> (Exp,Exp) -> M SwitchAlt
+alt a (LitE b, c) = do
+ ss <- block_ (store a) c
+ return $ SwitchAlt b ss
+alt a (AppE (b@LitE{}) _, c) = alt a (b,c)
+alt a (b,c) = error $ "alt:pattern match failed:" ++ show (a,b,c)
+
+store :: TVar -> Exp -> M Atom
+store a b = do
+ e <- atom b
+ stmt $ StoreS a e
+ return voidA
+
+fresh :: Type -> M TVar
+fresh a = return $ TVar (uId a "v") a
+
+fExitS :: [Stmt] -> Maybe [Stmt]
+fExitS ss = case break isExitS ss of
+ (_,[]) -> Nothing
+ (_,[_]) -> Nothing
+ (bs,c:_) -> Just $ bs ++ [c]
+ where
+ isExitS (CallS a _) = vtvar a == "exit"
+ isExitS _ = False
+
+fVoidT :: Type -> Maybe Type
+fVoidT (Type "Fun_" xs0) | any isVoidTy xs =
+ Just $ Type "Fun_" $ filter (not . isVoidTy) xs ++ [x]
+ where
+ xs = init xs0
+ x = last xs0
+fVoidT _ = Nothing
+
+fSynT :: Type -> Maybe Type
+fSynT (Type a _) = case a of
+ "Idx_" -> Just $ I.Type "W_" [I.Type "Cnt32" []]
+ "IString_" -> Just $ I.Type "Ptr_" [I.Type "Char_" []]
+ _ -> Nothing
+
+fCastE :: I.Exp -> Maybe I.Exp
+fCastE (I.CastE a b) | ttvar a == b = Just $ I.AtomE $ VarA a
+fCastE _ = Nothing
+
+dModule :: FilePath -> String -> [String] -> [Define] -> IO ()
+dModule outdir a bs cs = do
+ let m = Module a (map Import bs) cs
+ let m1 =
+ rewriteBi fCastE $
+ rewriteT $
+ rewriteBi fExitS $
+ rewriteBi fNoOpS $
+ rewriteBi fVoidD $
+ rewriteBi fVoidE $
+ rewriteBi fVoidS m
+ x <- cmdArgs argsDesc
+ case march x of
+ C -> cModules outdir (readable x) m1
+ LLVM -> L.dModule outdir m1
+
+rewriteT :: Data a => a -> a
+rewriteT x = rewriteBi fVoidT $ rewriteBi fSynT x
+
+addGTyDecls :: [(Type,TyDecl)] -> ()
+{-# NOINLINE addGTyDecls #-}
+addGTyDecls xs = unsafePerformIO $ modifyMVar_ gTyDecls $ \ys ->
+ return $ union (rewriteT xs) ys
+
+defn :: Typed a => E a -> Define
+defn x = case unE x of
+ DefE (TVar a0 t) b -> flip evalState initSt $ do
+ let a = if a0 == "main_" then "main" else a0
+ let (vs,c) = unLam b
+ e <- atom c
+ ss <- pop_block
+ return $ Define (fst $ unFunTy t) a vs $ ss ++ [ReturnS e]
+ _ -> error "defn"
+
+unLam :: Exp -> ([TVar],Exp)
+unLam x = case x of
+ LetE a b c -> let (vs,e) = unLam c in (vs, LetE a b e)
+ LamE (TVar a b) f -> let (vs,e) = unLam $ f $ VarE v in (v:vs, e)
+ where v = TVar (a ++ "_") b
+ _ -> ([],x)
+
+appE :: (Typed a, Typed b) => E (a -> b) -> E a -> E b
+appE a b = case unE a of
+ LamE _ f -> setE (f $ unE b)
+ _ -> setE (AppE (unE a) (unE b))
+
+data Array_ cnt a
+data Pointer_ p a
+
+class Load_ a
+class Store_ a
+
+data IString_
+
+data I_ a
+data W_ a
+data Idx_ a
+
+instance Count a => Arith_ (I_ a)
+instance Count a => Arith_ (W_ a)
+instance Arith_ Double_
+instance Arith_ Float_
+
+instance Floating_ Double_
+instance Floating_ Float_
+
+instance Count a => Nmbr (I_ a)
+instance Count a => Nmbr (W_ a)
+instance Count a => Nmbr (Idx_ a)
+instance Nmbr Double_
+instance Nmbr Float_
+
+class Ord_ a
+class Eq_ a
+
+instance Eq_ Char_
+instance Eq_ IString_
+
+instance Count a => Ord_ (I_ a)
+instance Count a => Ord_ (W_ a)
+instance Ord_ Char_
+instance Ord_ Double_
+instance Ord_ Float_
+
+instance Count a => Eq_ (W_ a)
+instance Count a => Eq_ (I_ a)
+instance Count a => Eq_ (Idx_ a)
+
+count_ :: (Count ca, Count cb, Typed a, Typed p) =>
+ E (Pointer_ p (Array_ ca a) -> W_ cb)
+count_ = lamE "" f
+ where
+ f :: (Count ca, Count cb, Typed a, Typed p) =>
+ E (Pointer_ p (Array_ ca a)) -> E (W_ cb)
+ f (_ :: E (Pointer_ p (Array_ cnt a))) =
+ nmbrE (show $ countof (unused :: cnt))
+
+data Char_
+data Double_
+data Float_
+
+data Tag a
+
+class Typed a => Count a where
+ countof :: a -> Integer
+ idx_max_ :: E (Idx_ a)
+ idx_max_ = nmbrE (show $ pred $ countof (unused :: a))
+
+instance Tagged a => Tagged (Tag a) where
+ tags (_ :: Tag a) = tags (unused :: a)
+
+class StorePtr a
+class Typed a => Nmbr a
+class Nmbr a => Arith_ a
+class Floating_ a
+
+tyPair :: Type -> Type -> Type
+tyPair a b = Type "Pair_" [a,b]
+
+unTyPtr :: Type -> Type
+unTyPtr (Type _ [a]) = a
+unTyPtr _ = error "unTyPtr"
+
+tyPtr :: Type -> Type
+tyPtr a = Type "Ptr_" [a]
+
+tyBool :: Type
+tyBool = tyPrim "Bool_"
+
+enumTyDecls :: Typed a => [String] -> a -> [(Type, TyDecl)]
+enumTyDecls ss a = [(ty a, tyEnum ss)]
+
+class Tagged a where
+ tags :: a -> [String]
+
+taggedTyDecls :: Typed a =>
+ [[(Type,TyDecl)]] -> [(String,Type)] -> a -> [(Type, TyDecl)]
+taggedTyDecls xs ys z = nub $ concat xs ++
+ [ (Type (s ++ "tag") [], tyEnum $ map fst ys)
+ , (t, TyTagged [ ConC a b | (a,b) <- ys ])
+ ]
+ where
+ t@(Type s _) = ty z
+
+recordTyDecls :: Typed a =>
+ [[(Type,TyDecl)]] -> [(String,Type)] -> a -> [(Type, TyDecl)]
+recordTyDecls xs ys z =
+ nub $ concat xs ++ [(ty z, TyRecord [ FieldT a b | (a,b) <- ys ])]
+
+class Typed a where
+ ty :: a -> Type
+ tydecls :: a -> [(Type, TyDecl)]
+ tydecls _ = []
+
+tydecls_ :: (Typed a, Typed b) => a -> b -> [(Type, TyDecl)]
+tydecls_ a _ = tydecls a
+
+instance Count a => Typed (I_ a) where
+ ty _ = Type "I_" [ty (unused :: a)]
+
+instance Count a => Typed (W_ a) where
+ ty _ = Type "W_" [ty (unused :: a)]
+
+instance Count a => Typed (Idx_ a) where
+ ty _ = Type "Idx_" [ty (unused :: a)]
+
+instance Typed a => Typed (Tag a) where
+ ty _ = Type (s ++ "tag") []
+ where I.Type s _ = ty (unused :: a)
+
+instance Typed () where
+ ty _ = tyVoid
+
+instance (Typed a, Typed b) => Typed (a -> b) where
+ ty _ = tyFun (ty (unused :: a)) (ty (unused :: b))
+ tydecls _ =
+ tydecls (unused :: a) ++ tydecls (unused :: b)
+
+instance (Count cnt, Typed a) => Typed (Array_ cnt a) where
+ ty _ = tyArray (countof (unused :: cnt)) (ty (unused :: a))
+ tydecls _ = tydecls (unused :: a)
+
+tyArray :: Integer -> Type -> Type
+tyArray a b = Type "Array_" [tyCnt a, b]
+
+instance Typed Char_ where
+ ty _ = tyChar
+
+instance Typed Double_ where
+ ty _ = tyDouble
+
+instance Typed Float_ where
+ ty _ = tyFloat
+
+instance Typed IString_ where
+ ty _ = tyIString
+
+instance (Typed p, Typed a) => Typed (Pointer_ p a) where
+ ty _ = tyPtr (ty (unused :: a))
+ tydecls _ = tydecls (unused :: a)
+
+isVoidTy :: Type -> Bool
+isVoidTy = (==) tyVoid
+
+tyVoid :: Type
+tyVoid = tyPrim "Void_"
+
+tyPrim :: String -> Type
+tyPrim a = Type a []
+
+letE :: (Typed a, Typed b) => String -> E a -> (E a -> E b) -> E b
+letE a0 b f =
+ let a = uId a0 a0 in
+ setE (LetE (TVar a (tof $ unE b)) (unE b) $ unE $ f $ varE a)
+
+tyFun :: Type -> Type -> Type
+tyFun a b = case b of
+ Type "Fun_" cs -> Type "Fun_" (a:cs)
+ _ -> Type "Fun_" [a,b]
+
+tof :: Exp -> Type
+tof x = case x of
+ VarE a -> ttvar a
+ DefE a _ -> ttvar a
+ LamE (TVar a b) f -> tyFun b (tof $ f $ VarE $ TVar a b)
+ AppE a _ -> case tail ts of
+ [] -> t
+ bs -> Type "Fun_" $ bs ++ [t]
+ where (t,ts) = unFunTy $ tof a
+ SwitchE _ b _ -> tof b
+ LitE (TLit _ b) -> b
+ LetE _ _ c -> tof c
+
+fixArity :: Int -> Type -> Type
+fixArity 0 x = x
+fixArity n x = case splitAt n ts of
+ (_,[]) -> x
+ (bs,cs) -> Type "Fun_" $ bs ++ [Type "Fun_" $ cs ++ [t]]
+ where
+ (t,ts) = unFunTy x
+
+arityDefE :: Typed a => Int -> String -> E a -> E a
+arityDefE n a b = setE (DefE (TVar a (fixArity n $ tof e)) e)
+ where e = unE b
+
+defE :: Typed a => String -> E a -> E a
+defE a b = arityDefE (arityDef $ unE b) a b
+
+arityDef :: Exp -> Int
+arityDef = length . fst . unLam
+
+extern :: Typed a => E (IString_ -> IString_ -> a)
+extern = lamE "" $ \x -> lamE "" $ \y ->
+ let v = unStringE x in arityDefE (read $ unStringE y) v (varE v)
+
+unStringE :: E IString_ -> String
+unStringE x = case unE x of
+ LitE (TLit (StringL s) _) -> s
+ _ -> error "unStringE"
+
+varE :: Typed a => String -> E a
+varE = f (error "unused:varE")
+ where
+ f :: Typed a => a -> String -> E a
+ f a s = setE (VarE $ TVar s (ty a))
+
+lamE :: (Typed a, Typed b) => String -> (E a -> E b) -> E (a -> b)
+lamE s (f :: (E a -> E b)) =
+ setE (LamE (TVar s (ty (unused :: a))) (\e -> unE (f (setE e))))
+
+switchE :: (Typed a, Typed b) => E a -> E b -> [(E a, E b)] -> E b
+switchE a b cs = setE (SwitchE (unE a) (unE b)
+ [ (unE x, unE y) | (x,y) <- cs ])
+
+switchE_ :: (Tagged a, Typed a, Typed b) => E a -> [(E a, E b)] -> E b
+switchE_ (a :: E a) bs = case tags (unused :: a) \\ xs of
+ [] -> switchE a (snd $ last bs) (init bs)
+ ts -> error $ "unmatched tag(s):" ++ unwords (take 10 ts)
+ where
+ xs = map (get_tag . unE . fst) bs
+
+get_tag :: Exp -> String
+get_tag x = case x of
+ AppE a _ -> get_tag a
+ LitE (TLit (EnumL a) _) -> a
+ _ -> error "unused:get_tag"
+
+litE :: Lit -> Type -> Exp
+litE a b = LitE (TLit a b)
+
+charE :: Char -> E Char_
+charE x = setE $ litE (CharL x) tyChar
+
+stringE :: String -> E IString_
+stringE x = setE $ litE (StringL x) tyIString
+
+nmbrE :: Nmbr a => String -> E a
+nmbrE = f (error "unused:nmbrE")
+ where
+ f :: Nmbr a => a -> String -> E a
+ f a i = setE $ litE (NmbrL i) (ty a)
+
+tyChar :: Type
+tyChar = tyPrim "Char_"
+
+tyDouble :: Type
+tyDouble = tyPrim "Double_"
+
+tyFloat :: Type
+tyFloat = tyPrim "Float_"
+
+tyIString :: Type
+tyIString = tyPrim "IString_"
+
+tyCnt :: Integer -> Type
+tyCnt x = tyPrim ("Cnt" ++ show x)
+
+un :: (Typed a, Typed b, Typed p, Load_ p) =>
+ E (IString_ -> Pointer_ p a -> b)
+un = varE "un"
+
+tg :: (Typed a) => E (IString_ -> a)
+tg = f (error "unused:tg")
+ where
+ f :: (Typed a) => a -> E (IString_ -> a)
+ f a = lamE "" $ \x -> setE $ litE (EnumL $ unStringE x) (ty a)
+
+storeE :: (Typed a, Typed p, Store_ p) => E (Pointer_ p a -> a -> ())
+storeE = varE "store"
+
+fld :: (Typed a, Typed b, Typed p) =>
+ E (IString_ -> Pointer_ p a -> Pointer_ p b)
+fld = lamE "" $ \x -> lamE "" $ \y -> appE (varE $ unStringE x ++ "fld") y
+
+unwrap_ :: (Typed a, Typed b) => E (IString_ -> a -> b)
+unwrap_ = lamE "" $ \_ -> lamE "" $ \a -> setE (unE a)
+
+unwrapptr_ :: (Typed a, Typed b, Typed p) =>
+ E (IString_ -> Pointer_ p a -> Pointer_ p b)
+unwrapptr_ = lamE "" $ \_ -> lamE "" $ \a -> setE (unE a)
+
+mk :: (Typed a) => E (IString_ -> a)
+mk = varE "mk"
+
+uni :: (Typed a) => E (IString_ -> a)
+uni = lamE "" $ \_ -> setE (LitE voidL)
+
+voidL :: TLit
+voidL = TLit VoidL tyVoid
+
+voidA :: Atom
+voidA = LitA voidL
+
+voidE :: I.Exp
+voidE = I.AtomE voidA
+
+nt :: (Typed a, Typed b) => E (IString_ -> a -> b)
+nt = lamE "" $ \_ -> lamE "" $ \a -> setE (unE a)
+
+tagv :: (Typed a, Typed b, Typed p, Load_ p) => E (Pointer_ p a -> b)
+tagv = varE "tagv"
+
+unsafe_cast_ :: (Typed a, Typed b) => E (a -> b)
+unsafe_cast_ = varE "unsafe_cast"
diff --git a/Pec/C.hs b/Pec/C.hs
new file mode 100644
--- /dev/null
+++ b/Pec/C.hs
@@ -0,0 +1,610 @@
+{-# OPTIONS -Wall #-}
+
+-- The pec embedded compiler
+-- Copyright 2011-2012, Brett Letner
+
+module Pec.C (cModules) where
+
+import Control.Concurrent
+import Control.Monad
+import Data.Char
+import Data.Generics.Uniplate.Data
+import Data.List
+import Data.Maybe
+import Development.Shake.FilePath
+import Grm.Prims
+import Language.C.Abs
+import Pec.IUtil
+import qualified Language.Pir.Abs as I
+
+cModules :: FilePath -> Bool -> I.Module -> IO ()
+cModules outdir is_readable (I.Module a _bs cs) = do
+ let defs = map cDefine cs
+ writeFileBinary (joinPath [outdir, n ++ ".c"]) $ ppShow $
+ cleanup $ optimize $ dModule is_readable $
+ CModule [Import hnfn] defs
+ xs <- liftM (nub . map cTypeD) $ readMVar gTyDecls
+ let ifvs = nub [ ifv | ifv@(I.TVar v _) <- concatMap fvsIDefine cs
+ , v `notElem` cBuiltins ]
+ writeFileBinary (joinPath [outdir, hnfn]) $ ppShow $
+ cleanup $
+ transformBi tArrayArgTy $
+ HModule hn hn imps $ xs ++ map (Declare . cFunDecl) ifvs
+ where
+ hn = n ++ "_H"
+ hnfn = n ++ ".h"
+ n = case a of
+ "" -> error "unused:cModules"
+ _ -> init a
+ imps = map GImport
+ [ "stdio.h"
+ , "stdint.h"
+ , "stdlib.h"
+ , "string.h"
+ ]
+
+cBuiltins :: [String]
+cBuiltins = [ "puts", "putchar", "strlen", "strncpy", "strcmp"] -- BAL: figure out how to handle this generically
+
+cTypeD :: (I.Type, I.TyDecl) -> Declare
+cTypeD (x@(I.Type s _),y) = Typedef $ Decl t (tyName x)
+ where
+ t = case y of
+ I.TyEnum bs -> TyEnum [ EnumC b | I.EnumC b <- bs ]
+ I.TyRecord bs -> TyStruct [ cDecl $ I.TVar c d | I.FieldT c d <- bs ]
+ I.TyTagged bs -> TyStruct
+ [ Decl (TyName $ s ++ "tag") "tag"
+ , Decl (TyUnion [ cDecl $ I.TVar c d | I.ConC c d <- bs
+ , d /= tyVoid ]) "data"
+ ]
+
+cDecl :: I.TVar -> Decl
+cDecl (I.TVar a b) = Decl (cType b) a
+
+cType :: I.Type -> Type
+cType x@(I.Type a bs) = case a of
+ "Fun_" -> TyFun (cType $ last bs) (map cType $ init bs)
+ "Ptr_" -> case bs of
+ [t] -> TyPtr (cType t)
+ _ -> error "cType:TyPtr"
+ "Array_" -> case bs of
+ [c,d] -> TyArray (cType d) (nCnt [c])
+ _ -> error "cType:TyArray"
+ _ -> cTyName x
+
+cTyName :: I.Type -> Type
+cTyName = TyName . tyName
+
+tyName :: I.Type -> String
+tyName (I.Type a bs) = case (a,bs) of
+ ("Void_",[]) -> "void"
+ ("W_",_) -> "uint" ++ (promote $ nCnt bs) ++ "_t"
+ ("I_",_) -> "int" ++ (promote $ nCnt bs) ++ "_t"
+ ("Double_",[]) -> "double"
+ ("Float_",[]) -> "float"
+ ("Char_",[]) -> "char"
+ ("Fun_",_) -> tyName (I.Type (a ++ show (length bs)) bs)
+ _ -> mkTyConstr (a : map tyName bs)
+
+mkTyConstr :: [String] -> String
+mkTyConstr ss = concat $ intersperse "_" $ map strip_underscore ss
+
+cDefine :: I.Define -> Define
+cDefine x@(I.Define a b cs d) =
+ Define (funDecl a b cs) $ map (DeclS . cDecl) (lvsIDefine x) ++ cBlock d
+
+funDecl :: I.Type -> Lident -> [I.TVar] -> FunDecl
+funDecl a b cs = case cType a of
+ TyFun t ts -> RetFunFD t b vs ts
+ t -> FunFD t b vs
+ where vs = map cDecl cs
+
+cFunDecl :: I.TVar -> FunDecl
+cFunDecl (I.TVar a b) = case b of
+ I.Type "Fun_" xs -> funDecl (last xs) a (map (I.TVar "") $ init xs)
+ _ -> error "unused:cFunDecl:not TyFun"
+
+cExp :: I.Exp -> Exp
+cExp x = case x of
+ I.CallE f [b] | has_suffix "_fld" $ vtvar f ->
+ AddrE $ ArrowE (cAtom b) $ VarE $ drop_suffix "fld" (vtvar f)
+ I.CallE f [b] | vtvar f == "tagv" -> ArrowE (cAtom b) (enum "tag")
+ I.CallE f [b,c] | vtvar f == "un" ->
+ AddrE $ ArrowE (cAtom c) $ DotE (VarE "data") (cTag b)
+ I.CallE f [b,c] | vtvar f == "idx" ->
+ IdxE (cAtom b) (cAtom c)
+ I.CallE a [b,c] | isBinOp a -> BinOpE (cAtom b) (cBinOp a) (cAtom c)
+ I.CallE a bs -> CallE (cVarE a) $ map cAtom bs
+ I.AtomE a -> cAtom a
+ I.CastE a@(I.TVar _ t) b
+ | isTypeEquiv t b -> cVarE a
+ | otherwise -> CastE (cType b) (cVarE a)
+ I.AllocaE a -> AllocaE $ cType a
+ I.LoadE a -> LoadE $ cVarE a
+
+cTag :: I.Atom -> Exp
+cTag x = case x of
+ I.LitA (I.TLit (I.EnumL a) _) -> enum a
+ I.LitA (I.TLit (I.StringL a) _) -> enum a -- BAL: should be EnumL...
+ _ -> error $ "cTag:" ++ ppShow x
+
+enum :: Uident -> Exp
+enum = LitE . EnumL
+
+cVarE :: I.TVar -> Exp
+cVarE (I.TVar a _) = VarE a
+
+cStmt :: I.Stmt -> [Stmt]
+cStmt x = case x of
+ I.LetS a b -> case b of
+ I.CallE f [c] | vtvar f == "mk" ->
+ [ AssignS (DotE (cVarE a) (enum "tag")) $ cTag c ]
+ I.CallE f [c,d] | vtvar f == "mk" ->
+ [ AssignS (DotE (cVarE a) (enum "tag")) $ cTag c
+ , AssignS (DotE (DotE (cVarE a) (enum "data")) (cTag c)) $
+ cAtom d
+ ]
+ I.CallE f [c] | vtvar f == "mk" ->
+ [AssignS (DotE (cVarE a) (enum "tag")) (cAtom c)]
+ _ -> [AssignS (cVarE a) (cExp b)]
+ I.StoreS a b -> [AssignS (LoadE $ cVarE a) (cAtom b)]
+ I.CallS a bs -> [CallS (cVarE a) $ map cAtom bs]
+ I.SwitchS a bs cs ->
+ [SwitchS (cAtom a) $ map cSwitchAlt cs ++
+ [DefaultAlt $ cBlock bs ++ [BreakS]]]
+ I.IfS a b c -> [IfS (cAtom a) (cBlock b) (cBlock c)]
+ I.WhenS a b -> [WhenS (cAtom a) (cBlock b)]
+ I.WhileS a b c -> ss ++ [WhileS (cAtom b) (cBlock c ++ ss)]
+ where ss = cBlock a
+ I.ReturnS (I.LitA (I.TLit I.VoidL _)) -> [RetVoidS]
+ I.ReturnS a -> [ReturnS (cAtom a)]
+ I.NoOpS -> error "unused:cStmt:NoOpS"
+
+cAtom :: I.Atom -> Exp
+cAtom x = case x of
+ I.VarA a -> cVarE a
+ I.LitA (I.TLit I.VoidL _) -> error "void atom not removed"
+ I.LitA a -> cTLitE a
+
+cTLitE :: I.TLit -> Exp
+cTLitE = LitE . cTLit
+
+cBlock :: I.StmtList -> [Stmt]
+cBlock = concatMap cStmt
+
+cSwitchAlt :: I.SwitchAlt -> SwitchAlt
+cSwitchAlt (I.SwitchAlt a b) =
+ SwitchAlt (cTLit a) (cBlock b ++ [BreakS])
+
+cTLit :: I.TLit -> Lit
+cTLit (I.TLit x y) = case x of
+ I.StringL a -> StringL a
+ I.CharL a -> CharL a
+ -- BAL add int and float suffixes
+ I.NmbrL a -> NmbrL $ case y of
+ I.Type "Float_" []
+ | isFloat a -> a
+ | otherwise -> show (readNumber a :: Double) ++ "f"
+ I.Type "Double_" []
+ | isFloat a -> a
+ | otherwise -> show (readNumber a :: Double)
+ _ | isFloat a -> error $ "integral type with float syntax:" ++ a ++
+ ":" ++ ppShow y
+ | isBinary a -> show (readBinary a)
+ | isOctal a -> '0' : drop 2 a
+ | otherwise -> a
+ I.EnumL a -> EnumL a
+ I.VoidL -> error "unused:cLTit:VoidL"
+
+cleanup :: Module -> Module
+cleanup x =
+ rewriteBi tTypeD $
+ transformBi tVarName $
+ transformBi tName $
+ x
+
+tMath :: Stmt -> Maybe Stmt
+tMath (AssignS a (BinOpE b "+" (LitE (NmbrL s)))) -- BAL: Don't do if float/double?
+ | a == b && (readNumber s :: Integer) == 1 = Just $ IncS a
+tMath (AssignS a (BinOpE b "-" (LitE (NmbrL s)))) -- BAL: Don't do if float/double?
+ | a == b && (readNumber s :: Integer) == 1 = Just $ DecS a
+tMath _ = Nothing
+
+tVarName :: Define -> Define
+tVarName x = transformBi k $ transformBi h x
+ where
+ tbl = concatMap g $ groupBy (\a b -> f a == f b) $
+ sort [ v | Decl _ v <- universeBi x ]
+ f s =
+ case reverse $ dropWhile (\c -> isDigit c || c == '_') $ reverse s of
+ "" -> "_"
+ s1 -> s1
+ g ss = case ss of
+ [s] -> [(s, f s)]
+ _ -> [ (s, f s ++ show i) | (s,i) <- zip ss [0 :: Int .. ]]
+ h (VarE v) = case lookup v tbl of
+ Nothing -> VarE v
+ Just v1 -> VarE v1
+ h a = a
+ k (Decl t v) = case lookup v tbl of
+ Nothing -> error "unused:tVarName"
+ Just v1 -> Decl t v1
+ k a = a
+
+optimize :: Module -> Module
+optimize x =
+ rewriteBi canon $
+ rewriteBi tNoOpS $
+ rewriteBi canonSS $
+ rewriteBi opt $
+ x
+
+opt :: Stmt -> Maybe Stmt
+opt (IfS e a _) | isTrue e = Just $ BlockS a
+opt (IfS e _ b) | isFalse e = Just $ BlockS b
+opt (WhenS e a) | isTrue e = Just $ BlockS a
+opt (WhenS e _) | isFalse e = Just NoOpS
+opt (WhileS e _) | isFalse e = Just NoOpS
+opt _ = Nothing
+
+canon :: Stmt -> Maybe Stmt
+canon (IfS e a []) = Just $ WhenS e a
+canon (IfS e [] b) = Just $ WhenS (NotE e) b
+canon _ = Nothing
+
+canonSS :: [Stmt] -> Maybe [Stmt]
+canonSS xs | any isBlockS xs = Just $ concatMap f xs
+ where f (BlockS ss) = ss
+ f s = [s]
+canonSS _ = Nothing
+
+isBlockS :: Stmt -> Bool
+isBlockS BlockS{} = True
+isBlockS _ = False
+
+isTrue :: Exp -> Bool
+isTrue (LitE (EnumL "True_")) = True
+isTrue _ = False
+
+isFalse :: Exp -> Bool
+isFalse (LitE (EnumL "False_")) = True
+isFalse _ = False
+
+dModule :: Bool -> Module -> Module
+dModule is_readable x =
+ rewriteBi canon $
+ rewriteBi tNoOpS $
+ rewriteBi canonSS $
+ rewriteBi tMath $
+ transformBi tSort $
+ transformBi reParen $
+ transformBi tArray $
+ transformBi tArrayArgTy $
+ transformBi tUnused $
+ (if is_readable then rewriteBi tLive else id) $
+ transformBi tOnlyAssigned $
+ transformBi tBlock $
+ rewriteBi tNoOpS $
+ rewriteBi tNoOpE $
+ transformBi tPtr $
+ rewriteBi tNoOpS $
+ rewriteBi tNoOpE $
+ transformBi tRHS $
+ rewriteBi tNoOpS $
+ rewriteBi tNoOpE $
+ transformBi tLHS $
+ transformBi tAlloca $
+ transformBi tLit $
+ x
+
+tTypeD :: Decl -> Maybe Decl
+tTypeD (Decl (TyArray a b) c) = Just $ Decl a $ c ++ "[" ++ b ++ "]"
+tTypeD (Decl (TyPtr a) b) = Just $ Decl a $ "(*" ++ b ++ ")"
+tTypeD (Decl (TyFun t ts) x) = Just $ FunD t ("(*" ++ x ++ ")") ts
+tTypeD _ = Nothing
+
+tArray :: Define -> Define
+tArray x = transformBi i $ transformBi h $ transformBi g x
+ where
+ vs = [ v | Decl (TyArray{}) v <- universeBi x ]
+
+ f (AddrE (VarE v)) | v `elem` vs = VarE v -- C passes arrays by reference
+ f a = a
+
+ g (CallE a bs) = CallE a $ map f bs
+ g a = a
+
+ h (CallS a bs) = CallS a $ map f bs
+ h a = a
+
+ i (AssignS a@(VarE v) b) | v `elem` vs =
+ CallS (VarE "memcpy") [a, b, CallE (VarE "sizeof") [a]]
+ i a = a
+
+tSort :: Define -> Define
+tSort (Define x ys) = Define x $ sortBy f cs ++ ds
+ where
+ (cs,ds) = partition isDeclS ys
+ f (DeclS a) (DeclS b) = compare (declNm a) (declNm b)
+ f _ _ = error "unused:tSort"
+
+isDeclS :: Stmt -> Bool
+isDeclS DeclS{} = True
+isDeclS _ = False
+
+tName :: Module -> Module
+tName x = transformBi j $ transformBi i $ transformBi h $ transformBi g $
+ transformBi f x
+ where
+ f (Decl a b) = Decl a $ rName b
+ f _ = error "unused:tName"
+ g (VarE a) = VarE $ rName a
+ g a = a
+ h (FunFD a b cs) = FunFD a (rName b) cs
+ h (RetFunFD a b cs ds) = RetFunFD a (rName b) cs ds
+ i (EnumC a) = EnumC $ rName a
+ j (EnumL a) = EnumL $ rName a
+ j a = a
+
+rName :: String -> String
+rName x = strip_underscore $ map f $ filter ((/=) '~') x
+ where
+ f '.' = '_'
+ f c = c
+
+tBlock :: Define -> Define
+tBlock x = transformBi f x
+ where
+ tbl :: [(String,Stmt)]
+ tbl = catMaybes $ map h $ universeBi x
+ f :: Stmt -> Stmt
+ f s0@(AssignS (VarE v) e) = case lookup v tbl of
+ Nothing -> s0
+ Just s -> transformBi g s
+ where
+ g (VarE v1) | v1 == v = e
+ g a = a
+ f s | s `elem` map snd tbl = NoOpS
+ f s = s
+
+ h :: Stmt -> Maybe (String,Stmt)
+ h s = case [ v | VarE v <- universeBi s, isFreshVar v ] \\ vs of
+ [v] -> Just (v,s)
+ _ -> Nothing
+ where
+ vs = case s of
+ AssignS e _ -> [basename e]
+ ReturnS e -> [basename e]
+ _ -> []
+
+-- make sure arithmetic expressions are fully parenthesized
+reParen :: Exp -> Exp
+reParen (ArrowE (AddrE a) b) = DotE a b
+reParen (DotE (LoadE a) b) = ArrowE a b
+reParen (CallE a@LoadE{} bs) = CallE (ParenE a) bs
+reParen x = x
+
+tUnused :: Define -> Define
+tUnused (Define a bs) = Define a (filter f bs)
+ where
+ f (DeclS x) = declNm x `elem` vs
+ f _ = True
+ vs = nub [ v | VarE v <- universeBi bs ]
+
+tOnlyAssigned :: Define -> Define
+tOnlyAssigned x = rewriteBi f x
+ where
+ vs = concat [ [v,v] | AssignS (VarE v) (CallE{}) <- universeBi x ] \\
+ [ v | VarE v <- universeBi x ]
+ f (AssignS (VarE v) (CallE a bs)) | v `elem` vs = Just $ CallS a bs
+ f _ = Nothing
+
+tNoOpE :: Exp -> Maybe Exp
+tNoOpE (LoadE (AddrE e)) = Just e
+tNoOpE (ArrowE (AddrE (ArrowE a b)) c) = Just $ DotE (ArrowE a b) c
+tNoOpE (IdxE (AddrE a) b) = Just $ AddrE (IdxE a b)
+tNoOpE _ = Nothing
+
+tNoOpS :: [Stmt] -> Maybe [Stmt]
+tNoOpS xs
+ | any isNoOpS xs = Just $ filter (not . isNoOpS) xs
+ | otherwise = Nothing
+
+isNoOpS :: Stmt -> Bool
+isNoOpS NoOpS = True
+isNoOpS (AssignS a b) = a == b
+isNoOpS (CallS (VarE "memcpy") [a, b, _]) = a == b
+isNoOpS _ = False
+
+declNm :: Decl -> String
+declNm (Decl _ v) = v
+declNm _ = error "unused:declNm"
+
+tLit :: Define -> Define
+tLit x = rewriteBi g $ rewriteBi f x
+ where
+ tbl = [ (v,e) | AssignS (VarE v) e@LitE{} <- universeBi x ]
+
+ f (AssignS (VarE v) _) | isJust (lookup v tbl) = Just NoOpS
+ f _ = Nothing
+
+ g (VarE v) = lookup v tbl
+ g _ = Nothing
+
+tAlloca :: Define -> Define
+tAlloca x@(Define fd _) =
+ transformBi g $ transformBi f $ rewriteBi h x
+ where
+ vs = [ v | AssignS (VarE v) AllocaE{} <- universeBi x ] ++
+ [ v | Decl (TyPtr TyArray{}) v <- universeBi fd ]
+
+ f :: Exp -> Exp
+ f (ArrowE (AddrE (VarE v)) e) | v `elem` vs = DotE (VarE v) e
+ f (VarE v) | v `elem` vs = AddrE (VarE v)
+ f e = e
+
+ g (Decl (TyPtr t) v) | v `elem` vs = Decl t v
+ g a = a
+
+ h :: Stmt -> Maybe Stmt
+ h s | isAllocaS s = Just NoOpS
+ | otherwise = Nothing
+
+tArrayArgTy :: FunDecl -> FunDecl
+tArrayArgTy = transformBi f
+ where
+ f :: Type -> Type
+ f (TyPtr t@TyArray{}) = t
+ f x = x
+
+isAllocaS :: Stmt -> Bool
+isAllocaS (AssignS VarE{} AllocaE{}) = True
+isAllocaS _ = False
+
+tPtr :: Define -> Define
+tPtr x = transformBi h $ transformBi g $ rewriteBi f x
+ where
+ tbl = concat [ let e = VarE ('$':a) in [(a, AddrE e) ,(b, e)]
+ | AssignS (VarE a) (AddrE (VarE b)) <- universeBi x ]
+
+ f (VarE v) = lookup v tbl
+ f _ = Nothing
+
+ g (VarE ('$':v)) = VarE v
+ g e = e
+
+ h (Decl (TyPtr t) v) | v `elem` map fst tbl = Decl t v
+ h p = p
+
+tRHS :: Define -> Define
+tRHS x = rewriteBi f x
+ where
+ tbl = [ (v,e) | AssignS e (VarE v) <- universeBi x, isFreshVar v ]
+
+ f (VarE v) = lookup v tbl
+ f _ = Nothing
+
+tLHS :: Define -> Define
+tLHS x = rewriteBi f x
+ where
+ tbl = [ (v,e) | AssignS (VarE v) e <- universeBi x, isFreshVar v ]
+
+ f (VarE v) = lookup v tbl
+ f _ = Nothing
+
+isFreshVar :: String -> Bool
+isFreshVar v = '_' `notElem` v && isDigit (last v)
+
+-- Liveness
+tLive :: Define -> Maybe Define -- this is hacky and inefficient, but seems to work
+tLive x = case live_tbl x of
+ [] -> Nothing
+ (y:_) -> Just $ transformBi (f y) x
+ where
+ f (a,b) (VarE v) | v == a = VarE b
+ f _ a = a
+
+is_reuse :: (String,String) -> Bool
+is_reuse (a,b) = a /= b
+
+live_tbl :: Define -> [(Nm, Nm)]
+live_tbl (Define _ ss) =
+ filter is_reuse $ reuse $ liveSS [ d | DeclS d <- ss ] initSt $ sStmts ss
+
+sStmts :: [Stmt] -> [S]
+sStmts = concatMap sStmt . reverse
+
+basename :: Exp -> String
+basename x = case x of
+ VarE a -> a
+ DotE a _ -> basename a
+ AddrE a -> basename a
+ ArrowE a _ -> basename a
+ IdxE a _ -> basename a
+ CastE _ b -> basename b
+ LoadE a -> basename a
+ ParenE a -> basename a
+ _ -> error $ "unused:basename:" ++ ppShow x
+
+sStmt :: Stmt -> [S]
+sStmt x = case x of
+ AssignS a b -> sExp b ++ [Init $ basename a]
+
+ SwitchS a bs -> [Branch $
+ [ sStmts cs | DefaultAlt cs <- bs ] ++
+ [ sStmts cs | SwitchAlt _ cs <- bs ]
+ ] ++ sExp a
+ IfS a bs cs -> [Branch [sStmts bs, sStmts cs]] ++ sExp a
+ WhenS a bs -> [Branch [sStmts bs]] ++ sExp a
+ WhileS a bs -> [Loop $ sStmts bs ++ sExp a]
+
+ CallS a bs -> sExp a ++ concatMap sExp bs
+ ReturnS a -> sExp a
+
+ DeclS{} -> []
+ BreakS -> []
+ RetVoidS -> []
+ NoOpS -> []
+
+ BlockS ss -> sStmts ss
+ DecS{} -> error $ "unused:sStmt:DecS"
+ IncS{} -> error $ "unused:sStmt:IncS"
+
+sExp :: Exp -> [S]
+sExp x = [ Use v | VarE v <- universeBi x ]
+
+type Nm = String
+
+data S
+ = Use Nm
+ | Init Nm
+ | Branch [[S]]
+ | Loop [S]
+ deriving Show
+
+data St = St
+ { in_use :: [Nm]
+ , reuse :: [(Nm, Nm)]
+ } deriving Show
+
+initSt :: St
+initSt = St [] []
+
+liveSS :: [Decl] -> St -> [S] -> St
+liveSS vs = loop
+ where
+ loop st [] = st
+ loop st (x:xs) = case x of
+ Use a -> loop st1 xs
+ where st1 = st{ in_use = nub $ union [a] $ in_use st }
+ Init a | isJust $ lookup a $ reuse st -> loop st xs
+ Init a -> loop st1 xs
+ where
+ st1 = St{ in_use = in_use st \\ [a]
+ , reuse = nub ((a, a1) : reuse st)
+ }
+ a1 = reuse_nm a vs $ in_use st
+ Branch bs -> loop st1 xs
+ where
+ sts = map (loop st) bs
+ st1 = St{ in_use = nub $ foldr1 union $ map in_use sts
+ , reuse = nub (concatMap reuse sts)
+ }
+ Loop bs -> loop st $ concatMap no_inits bs ++ bs ++ xs
+
+reuse_nm :: Nm -> [Decl] -> [Nm] -> Nm
+reuse_nm a bs cs =
+ head $ sort $ a : ((map declNm $ filter (equiv_decl b0) bs) \\ cs)
+ where
+ b0 = head $ filter ((==) a . declNm) bs
+
+equiv_decl :: Decl -> Decl -> Bool
+equiv_decl (Decl a _) (Decl b _) = a == b
+equiv_decl _ _ = error "unused:equiv_decl"
+
+no_inits :: S -> [S]
+no_inits x = case x of
+ Init{} -> []
+ Use{} -> [x]
+ Branch bs -> concatMap (concatMap no_inits) bs
+ Loop bs -> concatMap no_inits bs
diff --git a/Pec/Desugar.hs b/Pec/Desugar.hs
new file mode 100644
--- /dev/null
+++ b/Pec/Desugar.hs
@@ -0,0 +1,455 @@
+{-# OPTIONS -Wall #-}
+
+-- The pec embedded compiler
+-- Copyright 2011-2012, Brett Letner
+
+module Pec.Desugar (desugar) where
+
+import Data.Char
+import Data.Either
+import Data.Generics.Uniplate.Data
+import Data.List
+import Data.Maybe
+import Grm.Prims
+import Language.Pec.Abs
+import Text.PrettyPrint.Leijen
+import qualified Language.Pds.Abs as D
+import Pec.PUtil
+
+desugar :: Module Point -> D.Module
+desugar = rewriteBi dTyCxt . dModule . tModule
+
+tModule :: Module Point -> Module Point
+tModule m =
+ rewriteBi dBlockE $ -- BAL: make it so we don't have to call these twice
+ rewriteBi dConstructedE $
+ rewriteBi dTupleE $
+ rewriteBi dPatE $
+ rewriteBi dBlockE $
+ rewriteBi dConstructedE $
+ rewriteBi unProcD $
+ transformBi (sortBy cmpFieldD) $
+ transformBi (sortBy cmpFieldT) $
+ transformBi (sortBy cmpConC) $
+ transformBi (\(Con p s) -> Con (p :: Point) $ usern s) $
+ transformBi (\(Field p s) -> Field (p :: Point) $ usern s) $
+ transformBi (\(Var p s) -> Var (p :: Point) $ usern s) m
+
+unCxt :: D.Type -> D.Type
+unCxt x = case x of
+ D.TyCxt _ b -> b
+ _ -> x
+
+isTyCxt :: D.Type -> Bool
+isTyCxt x = case x of
+ D.TyCxt{} -> True
+ _ -> False
+
+cxtOf :: D.Type -> D.CxtList
+cxtOf x = case x of
+ D.TyCxt a _ -> a
+ _ -> []
+
+tyCxt :: [D.Cxt] -> D.Type -> D.Type
+tyCxt xs y = D.TyCxt (sort $ nub xs) y
+
+dTyCxt :: D.Type -> Maybe D.Type
+dTyCxt x = case x of
+ D.TyCxt a b | isTyCxt b -> Just $ tyCxt (a ++ cxtOf b) (unCxt b)
+ D.TyFun a b | any isTyCxt [a,b] ->
+ Just $ tyCxt (cxtOf a ++ cxtOf b) $ D.TyFun (unCxt a) (unCxt b)
+ D.TyConstr a bs | any isTyCxt bs ->
+ Just $ tyCxt (concatMap cxtOf bs) $ D.TyConstr a $ map unCxt bs
+ _ -> Nothing
+
+dModule :: Module Point -> D.Module
+dModule (Module _ a b c ds) = D.Module (dModid a)
+ (dExportDecls ys xs b) (dImportDecls c) ys zs
+ (concatMap constrs ys ++ concatMap deconstrs ys ++ xs)
+ where
+ (ws,xs) = partitionEithers $ map dTopDecl $ unAscribeDs ds
+ (ys,zs) = partitionEithers ws
+
+usern :: String -> String
+usern s = case a of
+ "" -> b ++ "_"
+ _ -> a ++ "." ++ b ++ "_"
+ where
+ (a,b) = breakQual s
+
+breakQual :: String -> (String,String)
+breakQual s = (vModid $ qual $ init ss, last ss)
+ where ss = unqual s
+
+vModid :: String -> String
+vModid s
+ | null s = s
+ | '_' `elem` s =
+ error $ "underscore not allowed in module identifier:" ++ s
+ | otherwise = qual_to_und s ++ "_"
+
+dModid :: Modid Point -> String
+dModid = vModid . ppShow
+
+cmpFieldD :: FieldD Point -> FieldD Point -> Ordering
+cmpFieldD (FieldD _ a _) (FieldD _ b _) = compare a b
+
+cmpFieldT :: FieldT Point -> FieldT Point -> Ordering
+cmpFieldT (FieldT _ a _) (FieldT _ b _) = compare a b
+
+cmpConC :: ConC Point -> ConC Point -> Ordering
+cmpConC (ConC _ a _) (ConC _ b _) = compare a b
+
+dExportDecls :: [D.TypeD] -> [D.VarD] -> ExportDecls Point -> [D.ExportD]
+dExportDecls xs ys z = case z of
+ ExpAllD p -> concatMap (dSpec (Both p)) xs ++ map exVarD ys
+ ExpListD _ es -> concatMap (dExport xs) es
+
+dExport :: [D.TypeD] -> Export Point -> [D.ExportD]
+dExport xs y = case y of
+ VarEx{} -> [D.VarEx $ ppShow y]
+ TypeEx _ a b -> case [ d | d@(D.TypeD c _ _) <- xs, c == ppShow a ] of
+ [] -> error $ "unknown type in export list:" ++ ppShow a
+ (z:_) -> dSpec b z
+
+exVarD :: D.VarD -> D.ExportD
+exVarD (D.VarD a _ _) = D.VarEx a
+
+tTypeD :: D.TypeD -> D.Type
+tTypeD (D.TypeD a bs c) =
+ D.TyCxt cxt $ D.TyConstr a $ map (D.TyVarT . ppShow) bs
+ where cxt = nub $ universeBi c
+
+tTag :: D.Type -> D.Type
+tTag t = D.TyConstr "Tag" [t]
+
+constrs :: D.TypeD -> [D.VarD]
+constrs d@(D.TypeD _ _ x) = case x of
+ D.TySyn{} -> []
+ D.TyNewtype a b -> [ fun2 "mk" "nt" a $ f b t ]
+ D.TyUnit b -> [ fun2 "mk" "uni" b t ]
+ D.TyEnum bs -> [ fun2 "mk" "tg" b t | b <- bs ]
+ D.TyRecord{} -> []
+ D.TyTagged ys -> [ fun "mk" a $ f b t | D.ConC a b <- ys ]
+ where
+ t = tTypeD d
+ f ta tb = if ta == D.TyVoid then tb else D.TyFun ta tb
+
+deconstrs :: D.TypeD -> [D.VarD]
+deconstrs d@(D.TypeD _ _ x) = case x of
+ D.TySyn{} -> []
+ D.TyNewtype a b ->
+ [ fun "unwrap_" a (D.TyFun t b)
+ , let p = uId a "p" in
+ fun "unwrapptr_" a (D.TyFun (aptr p t) (aptr p b)) ]
+ D.TyUnit b -> [ fun2 "tg" "uni" b t ]
+ D.TyEnum bs -> [ fun "tg" b t | b <- bs ]
+ D.TyRecord ys ->
+ [ let p = uId a "p" in fun "fld" a (D.TyFun (aptr p t) (aptr p b))
+ | D.FieldT a b <- ys ]
+ D.TyTagged ys ->
+ [ fun "tg" a $ D.TyFun (rptr_ t) (tTag t) | D.ConC a _ <- ys ] ++
+ [ let p = uId a "p" in fun "un" a $
+ D.TyFun (rptr p t) (if b == D.TyVoid then b else rptr p b)
+ | D.ConC a b <- ys
+ ]
+ where
+ t = tTypeD d
+
+rptr :: String -> D.Type -> D.Type
+rptr p a =
+ D.TyCxt [ D.Cxt "Load_" [D.Var p]] $ aptr p a
+
+aptr :: String -> D.Type -> D.Type
+aptr p a = D.TyConstr "Pointer_" [D.TyVarT p ,a]
+
+rptr_ :: D.Type -> D.Type
+rptr_ a = let p = uId a "p" in rptr p a
+
+fun2 :: Pretty a => String -> String -> a -> D.Type -> D.VarD
+fun2 a x b c = D.VarD (lowercase s ++ a) D.Macro $
+ D.AscribeE (D.AppE (D.VarE x) (dExp $ stringE s)) c
+ where s = ppShow b
+
+fun :: Pretty a => String -> a -> D.Type -> D.VarD
+fun a = fun2 a a
+
+dSpec :: Spec Point -> D.TypeD -> [D.ExportD]
+dSpec a b@(D.TypeD c _ _) = case a of
+ Neither _ -> [D.TypeEx c]
+ Decon p -> dSpec (Neither p) b ++ map exVarD (deconstrs b)
+ Both p -> dSpec (Decon p) b ++ map exVarD (constrs b)
+
+un :: Pretty a => a -> String
+un x = lowercase (ppShow x) ++ "un"
+
+fld :: Pretty a => a -> String
+fld x = ppShow x ++ "fld"
+
+dImportDecls :: ImportDecls Point -> [D.ImportD]
+dImportDecls x = case x of
+ ImpListD _ a -> map f a
+ ImpNoneD _ -> []
+ where
+ f y = case y of
+ Import _ a (AsAS _ b) -> D.ImportD (dModid a) (D.AsAS $ dModid b)
+ Import _ a (EmptyAS _) -> D.ImportD (dModid a) D.EmptyAS
+
+dVar :: Pretty a => a -> D.Var
+dVar = D.Var . ppShow
+
+dTyArity :: D.Type -> Int
+dTyArity x = case x of
+ D.TyCxt _ b -> dTyArity b
+ D.TyFun _ b -> 1 + dTyArity b
+ _ -> 0
+
+dTopDecl :: TopDecl Point -> Either (Either D.TypeD D.InstD) D.VarD
+dTopDecl (VarD _ a b c) = Right $ D.VarD (ppShow a) (dDeclSym b) (dExp c)
+dTopDecl (ExternD p a b c) = Right $ D.VarD (ppShow b) D.Macro
+ (dExp $ AscribeE p (AppE p (AppE p (varE "extern") (stringE v))
+ (stringE $ show $ dTyArity $ dType c)) c)
+ where
+ v = case a of
+ SomeNm _ x -> x
+ NoneNm _ -> init $ ppShow b
+dTopDecl (TypeD0 p a bs) =
+ dTopDecl (TypeD p a bs $ TyTagged p [ConC p (Con p c) []]) -- BAL: should also use module name to avoid clashes.
+ where c = uId a (ppShow a)
+dTopDecl (TypeD _ a bs c) =
+ Left $ Left $ D.TypeD (ppShow a) (map dVar bs) $
+ case c of
+ TySyn _ x -> D.TySyn $ dType x
+ TyRecord _ xs -> D.TyRecord [ D.FieldT (ppShow y) (dType z)
+ | FieldT _ y z <- xs ]
+ TyTagged _ xs -> case xs of
+ [] -> error "unused:dTopDecl:[]" -- BAL: support?
+ [ConC _ y []] -> D.TyUnit (ppShow y)
+ [ConC p y zs] -> D.TyNewtype (ppShow y) $ dType $ TyTuple p zs
+ _ | all isEnumC xs ->
+ D.TyEnum [ D.EnumC (ppShow y) | ConC _ y [] <- xs ]
+ _ -> D.TyTagged [ D.ConC (ppShow y) (dType $ TyTuple p zs)
+ | ConC p y zs <- xs ]
+dTopDecl (InstD _ a b) = Left $ Right $ D.InstD (ppShow a) (dType b)
+dTopDecl _ = error "unused:dTopDecl"
+
+unAscribeDs :: [TopDecl Point] -> [TopDecl Point]
+unAscribeDs xs = foldr unAscribeD zs ys
+ where
+ (ys,zs) = partition isAscribeD xs
+
+unProcD :: TopDecl Point -> Maybe (TopDecl Point)
+unProcD (ProcD p a bs c d) = Just $ VarD p a c $ LamE p bs d
+unProcD _ = Nothing
+
+unAscribeD :: TopDecl Point -> [TopDecl Point] -> [TopDecl Point]
+unAscribeD (AscribeD _ x y) xs = case ys of
+ [] -> error $ "unknown ascription:" ++ ppShow x
+ _ -> [ VarD p a b $ AscribeE p c y | VarD p a b c <- ys ] ++ zs
+ where
+ (ys,zs) = partition f xs
+ f (VarD _ a _ _) = ppShow a == ppShow x
+ f _ = False
+unAscribeD _ _ = error "unused:unAscribeD"
+
+isAscribeD :: TopDecl Point -> Bool
+isAscribeD (AscribeD{}) = True
+isAscribeD _ = False
+
+isEnumC :: ConC Point -> Bool
+isEnumC (ConC _ _ xs) = null xs
+
+dTyVar :: TyVar Point -> D.Type
+dTyVar x = case x of
+ VarTV _ a -> D.TyVarT $ usern a
+ CntTV _ a -> D.TyCxt [D.Cxt "Count" [D.Var s]] $ D.TyVarT s
+ where s = usern a
+
+dDeclSym :: DeclSym Point -> D.DeclSym
+dDeclSym x = case x of
+ Macro _ -> D.Macro
+ Define _ -> D.Define
+
+dType :: Type Point -> D.Type
+dType x = case x of
+ TyCxt _ a b -> D.TyCxt (map dCxt a) (dType b)
+ TyFun _ a b -> D.TyFun (dType a) (dType b)
+ TyConstr _ a b -> D.TyConstr (ppShow a) $ map dType b
+ TyTuple p ts -> case ts of
+ [] -> D.TyVoid
+ [t] -> dType t
+ [a,b] -> dType $ TyConstr p (Con p "Pair_") [a,b]
+ (a:bs) -> dType $ TyTuple p [a, TyTuple p bs]
+ TyVarT _ a -> dTyVar a
+ TyConstr0 p a -> dType $ TyConstr p a []
+ TyArray p a b -> dType $ TyConstr p (Con p "Array_") [a,b]
+ TyCount p (Count _ a)
+ | all isDigit a -> dType $ TyConstr0 p (Con p $ "Cnt" ++ ppShow a)
+ | otherwise -> error "literal count types must be in decimal form"
+
+dCxt :: Cxt Point -> D.Cxt
+dCxt (Cxt _ a bs) = D.Cxt (ppShow a) $ map dVar bs
+
+varE :: Lident -> Exp Point
+varE = VarE p . Var p
+ where p = noPoint
+
+stringE :: String -> Exp Point
+stringE = LitE p . StringL p
+ where p = noPoint
+
+nmbrE :: Integer -> Exp Point
+nmbrE = LitE p . NmbrL p . show
+ where p = noPoint
+
+apps :: [Exp Point] -> Exp Point
+apps = foldl1 (AppE noPoint)
+
+dSwitchAlt :: SwitchAlt Point -> D.SwitchAlt
+dSwitchAlt (SwitchAlt _ a b) = D.SwitchAlt (dLit "tg" a) (dExp b)
+
+dCaseAlt :: Exp Point -> CaseAlt Point -> D.SwitchAlt
+dCaseAlt e (CaseAlt p a bs c) = D.SwitchAlt
+ (D.AppE (dLit "tg" $ EnumL p a) (dExp e))
+ (dExp $ rewriteBi dPatE $ LetE p (TupleE p $ map (VarE p) bs) (Macro p)
+ (AppE p (varE $ un a) e) c)
+
+tagv :: Exp Point -> D.Exp
+tagv a = dExp $ AppE (point a) (varE "tagv") a
+
+defE :: Exp Point -> Var Point -> Exp Point -> D.Exp
+defE a b c = dExp $ AppE (point a) (LamE (point c) [VarE (point b) b] c) a
+
+dBlockE :: Exp Point -> Maybe (Exp Point)
+dBlockE x = case x of
+ BlockE p0 ys -> case ys of
+ [] -> error "unused:dBlockE"
+ [y] -> Just y
+ (e:es) -> case e of
+ LetS p1 a b c -> Just $ LetE p1 a b c $ BlockE p0 es
+ _ -> Just $ apps [varE "then_", e, BlockE p0 es]
+ _ -> Nothing
+
+dPatE :: Exp Point -> Maybe (Exp Point)
+dPatE x = case x of
+ LamE p bs c -> case bs of
+ [] -> error "unused:dPatE"
+ [b] -> case unPat b c of
+ Nothing -> Nothing
+ Just (b1,c1) -> Just $ LamE p [b1] c1
+ (d:ds) -> Just $ LamE p [d] $ LamE p ds c
+ LetE p a b c d -> case unPat a d of
+ Nothing -> Nothing
+ Just (a1,d1) -> Just $ LetE p a1 b c d1
+ _ -> Nothing
+
+unPat :: Exp Point -> Exp Point -> Maybe (Exp Point, Exp Point)
+unPat x y = case x of
+ TupleE p xs -> case xs of
+ [] -> Just (AscribeE p (varE "_u") (TyTuple p []), y)
+ [a] -> Just (a, y)
+ [a,b] -> Just (v, LetE p a (Macro p) (apps [varE "fst_fld", v])
+ (LetE p b (Macro p) (apps [varE "snd_fld", v]) y))
+ where
+ v = varE $ uId x "p"
+ (e:es) -> Just (TupleE p [e, TupleE p es], y)
+ AscribeE _ a _ -> Just (a, apps [varE "ignore_", x, y])
+ VarE{} -> Nothing
+ _ -> error $ "unexpected pattern:" ++ ppShow x
+
+dExp :: Exp Point -> D.Exp
+dExp x = case x of
+ BlockE{} -> error "unused:dExp:BlockE"
+ LetS{} ->
+ error "malformed let statement (must not be the last expr in a block)"
+ LetE _ a b c d -> case a of
+ VarE{} -> D.LetE (ppShow a) (dDeclSym b) (dExp c) (dExp d)
+ _ -> error $ "unused:dExp:LetE:" ++ ppShow a
+ LamE _ bs c -> case bs of
+ [VarE _ (Var _ a)] -> D.LamE a (dExp c)
+ _ -> error "unused:dExp:LamE"
+ SwitchE _ a bs (DefaultNone{}) ->
+ D.SwitchE (dExp a) D.DefaultNone $ map dSwitchAlt bs
+ SwitchE _ a@(VarE{}) bs (DefaultAlt _ c d) ->
+ D.SwitchE (dExp a) (D.DefaultSome $ defE a c d) (map dSwitchAlt bs)
+ SwitchE p a bs c -> dExp $ LetE p v (Define p) a $ SwitchE p v bs c
+ where v = varE $ uId x "s"
+ CaseE _ a@(VarE{}) bs (DefaultNone{}) ->
+ D.SwitchE (tagv a) D.DefaultNone (map (dCaseAlt a) bs)
+ CaseE _ a@(VarE{}) bs (DefaultAlt _ c d) ->
+ D.SwitchE (tagv a) (D.DefaultSome $ defE a c d) (map (dCaseAlt a) bs)
+ CaseE p a bs c -> dExp $ LetE p v (Define p) a $ CaseE p v bs c
+ where v = varE $ uId x "c"
+ BranchE _ ys0 z -> case ys0 of
+ [] -> dExp z
+ (BranchAlt p a b : ys) ->
+ dExp $ apps [varE "if_", a, b, BranchE p ys z]
+ StoreE _ a b -> dExp $ apps [varE "store_", a, b]
+ BinOpE _ a b c -> dExp $ apps [opE b, a, c]
+ UnOpE p a b -> dExp $ AppE p (opE a) b
+ IdxE _ a b -> dExp $ apps [varE "idx_", a, b]
+ FldE p a b -> dExp $ AppE p (varE $ fld b) a
+ CountE _ (Count _ a) -> dCnt $ ppShow a
+ AppE _ a b -> D.AppE (dExp a) (dExp b)
+ ArrayE{} -> error "unused:dExp:ArrayE"
+ RecordE{} -> error "unused:dExp:RecordE"
+ TupleE{} -> error "unused:dExp:TupleE"
+ AscribeE _ a b -> D.AscribeE (dExp a) (dType b)
+ VarE _ a -> D.VarE $ ppShow a
+ LitE _ a -> dLit "mk" a
+
+dTupleE :: Exp Point -> Maybe (Exp Point)
+dTupleE (TupleE p xs) = case xs of
+ [] -> Just $ VarE p (Var p "void_")
+ [a] -> Just a
+ [a,b] -> Just $ RecordE p [ fieldD "fst_" a, fieldD "snd_" b ]
+ (a:bs) -> Just $ TupleE p [a, TupleE p bs]
+dTupleE _ = Nothing
+
+fieldD :: String -> Exp Point -> FieldD Point
+fieldD a e = FieldD p (Field p a) e
+ where p = point e
+
+countE :: Int -> Exp Point
+countE = CountE noPoint . Count noPoint . show
+
+dConstructedE :: Exp Point -> Maybe (Exp Point)
+dConstructedE (ArrayE p xs) = Just $ BlockE p $
+ [ LetS p v (Define p) $ AppE p (varE "unsafe_alloca_array_")
+ (countE $ length xs) ] ++
+ [ StoreE p (IdxE p v $ nmbrE i) x | (i,x) <- zip [0 .. ] xs ] ++
+ [ AppE p (varE "load_") v ]
+ where
+ v = varE $ uId xs "a"
+dConstructedE (RecordE p0 xs) = Just $ BlockE p0 $
+ [ LetS p0 v (Define p0) $ varE "unsafe_alloca_" ] ++
+ [ StoreE p (FldE p v a) b | FieldD p a b <- xs ] ++
+ [ AppE p0 (varE "load_") v ]
+ where
+ v = varE $ uId xs "r"
+dConstructedE _ = Nothing
+
+dCnt :: String -> D.Exp
+dCnt x = dExp $ varE $ "cnt" ++ x
+
+dLit :: String -> Lit Point -> D.Exp
+dLit suf x = case x of
+ CharL _ a -> D.LitE $ D.CharL a
+ StringL _ a -> D.LitE $ D.StringL a
+ NmbrL _ a -> D.LitE $ D.NmbrL a
+ EnumL{} -> dExp $ varE $ lowercase $ ppShow x ++ suf
+
+opE :: Pretty a => a -> Exp Point
+opE a = varE $ concatMap f $ ppShow a
+ where
+ f x = fromMaybe err $ lookup x
+ [ ('!', "bang_"), ('"', "dquote_"), ('#', "hash_"), ('$', "dollar_")
+ , ('%', "rem_"), ('&', "band_"), ('\'', "squote_"), ('(', "lparen_")
+ , (')', "rparen_"), ('*', "mul_"), ('+', "add_"), (',', "comma_")
+ , ('-', "sub_"), ('.', "dot_"), ('/', "div_"), (':', "colon_")
+ , (';', "semi_"), ('<', "lt_"), ('=', "eq_"), ('>', "gt_")
+ , ('?', "ques_"), ('@', "load_"), ('[', "lbrack_"), ('\\', "bslash_")
+ , (']', "rbrack_"), ('^', "bxor_"), ('`', "grave_"), ('{', "lbrace_")
+ , ('|', "bor_"), ('}', "rbrace_"), ('~', "bnot_")
+ ]
+ where err = error $ "unknown character in operator:" ++ show x
diff --git a/Pec/HUtil.hs b/Pec/HUtil.hs
new file mode 100644
--- /dev/null
+++ b/Pec/HUtil.hs
@@ -0,0 +1,48 @@
+{-# OPTIONS -Wall #-}
+
+-- The pec embedded compiler
+-- Copyright 2011-2012, Brett Letner
+
+module Pec.HUtil where
+
+import Data.List
+import Grm.Prims
+import Text.PrettyPrint.Leijen
+import qualified Language.Haskell as H
+
+nl :: H.SrcLoc
+nl = error "SRCLOC"
+
+hmodule :: String -> [String] -> Maybe [H.ExportSpec] -> [H.ImportDecl] -> [H.Decl] -> H.Module
+hmodule n ps = H.Module nl (H.ModuleName n)
+ [H.LanguagePragma nl [H.name p] | p <- ps ] Nothing
+
+importDecl :: [String] -> Bool -> String -> H.ImportDecl
+importDecl xs q n = (importDecl_ q n){ H.importSpecs = Just (True, map (H.IVar . H.name) xs) }
+
+importDecl_ :: Bool -> String -> H.ImportDecl
+importDecl_ q n = H.ImportDecl
+ { H.importModule = H.ModuleName n
+ , H.importQualified = q
+ , H.importLoc = nl
+ , H.importSrc = False
+ , H.importPkg = Nothing
+ , H.importAs = Nothing
+ , H.importSpecs = Nothing
+ }
+
+hinstdecl :: H.Context -> String -> [H.Type] -> [H.InstDecl] -> H.Decl
+hinstdecl qs n = H.InstDecl nl (nub $ sort qs) (H.qname n)
+
+hdatadecl :: String -> [H.TyVarBind] -> [H.QualConDecl] -> H.Decl
+hdatadecl n vs ds = H.DataDecl nl H.DataType [] (H.name n) vs ds []
+
+doList :: [H.Exp] -> H.Exp
+doList xs =
+ H.Do $ map H.Qualifier $ xs ++ [H.apps (H.var "return") [H.Tuple []]]
+
+hAppCon :: String -> H.Exp -> H.Exp
+hAppCon = H.App . H.con
+
+hString :: Pretty a => a -> H.Exp
+hString = H.Lit . H.String . ppShow
diff --git a/Pec/IUtil.hs b/Pec/IUtil.hs
new file mode 100644
--- /dev/null
+++ b/Pec/IUtil.hs
@@ -0,0 +1,159 @@
+{-# OPTIONS -Wall #-}
+
+-- The pec embedded compiler
+-- Copyright 2011-2012, Brett Letner
+
+module Pec.IUtil where
+
+import Data.List
+import Grm.Prims
+-- import Text.PrettyPrint.Leijen
+-- import qualified Language.Haskell as H
+import Language.Pir.Abs
+import Control.Concurrent
+import Data.Char
+import Data.Generics.Uniplate.Data
+import System.IO.Unsafe
+import Data.Maybe
+
+gTyDecls :: MVar [(Type,TyDecl)]
+gTyDecls = unsafePerformIO $ newMVar []
+
+fvsIDefine :: Define -> [TVar]
+fvsIDefine x@(Define _ _ _ ds) =
+ (nub $ filter f $ universeBi ds) \\ bvsIDefine x
+ where
+ f v@(TVar a _) = not (a `elem` builtins || isBinOp v || isFldOp a)
+
+isFldOp :: String -> Bool
+isFldOp = has_suffix "_fld"
+
+bvsIDefine :: Define -> [TVar]
+bvsIDefine x@(Define _ _ cs _) = nub (cs ++ lvsIDefine x)
+
+lvsIDefine :: Define -> [TVar]
+lvsIDefine (Define _ _ _ ds) = nub [ v | LetS v _ <- universeBi ds ]
+
+builtins :: [String]
+builtins = ["mk", "tagv", "idx", "un", "printf"]
+
+isTypeEquiv :: Type -> Type -> Bool
+isTypeEquiv a b = case (a,b) of
+ (Type "Char_" [], Type "W_" [Type "Cnt8" []]) -> True
+ (Type "W_" [Type "Cnt8" []], Type "Char_" []) -> True
+ _ -> False
+
+tyVoid :: Type
+tyVoid = Type "Void_" []
+
+vtvar :: TVar -> String
+vtvar (TVar a _) = a
+
+ttvar :: TVar -> Type
+ttvar (TVar _ b) = b
+
+ttlit :: TLit -> Type
+ttlit (TLit _ b) = b
+
+tatom :: Atom -> Type
+tatom x = case x of
+ LitA a -> ttlit a
+ VarA a -> ttvar a
+
+isBinOp :: TVar -> Bool
+isBinOp = isJust . lookupBinOp
+
+cBinOp :: TVar -> String
+cBinOp = fromJust . lookupBinOp
+
+lookupBinOp :: TVar -> Maybe String
+lookupBinOp v = lookup (vtvar v)
+ [ ("add","+")
+ , ("sub","-")
+ , ("mul","*")
+ , ("div","/")
+ , ("rem","%")
+ , ("gt",">")
+ , ("gte",">=")
+ , ("lt","<")
+ , ("lte","<=")
+ , ("eq","==")
+ , ("ne","!=")
+ , ("shl","<<")
+ , ("shr",">>")
+ , ("band","&")
+ , ("bor","|")
+ , ("bxor","^")
+ , ("bnot","~")
+ , ("and","&&")
+ , ("or","||")
+ ]
+
+nCnt :: [Type] -> Number
+nCnt [t@(Type cs [])] | isCnt t = filter isDigit cs
+nCnt _ = error "nCnt"
+
+isCnt :: Type -> Bool
+isCnt (Type ('C':'n':'t':cs) []) = not (null cs) && all isDigit cs
+isCnt _ = False
+
+has_suffix :: Eq a => [a] -> [a] -> Bool
+has_suffix a b = drop (length b - length a) b == a
+
+drop_suffix :: [a] -> [a] -> [a]
+drop_suffix a b = take (length b - length a) b
+
+promote :: Number -> Number
+promote s
+ | x <= 8 = "8"
+ | x <= 16 = "16"
+ | x <= 32 = "32"
+ | x <= 64 = "64"
+ | x <= 128 = "128"
+ | otherwise = error $ "too many bits required to represent number:" ++ show x
+ where
+ x = readNumber s :: Integer
+
+strip_underscore :: String -> String
+strip_underscore "" = ""
+strip_underscore s
+ | last s == '_' = case reverse $ dropWhile ((==) '_') $ reverse s of
+ [] -> "_"
+ s1 -> s1
+ | otherwise = s
+
+isSigned :: Type -> Bool
+isSigned x = case x of
+ Type "I_" [_] -> True
+ _ -> False
+
+isUnsigned :: Type -> Bool
+isUnsigned x = case x of
+ Type "W_" [_] -> True
+ _ -> False
+
+isFloating :: Type -> Bool
+isFloating x = case x of
+ Type "Double_" [] -> True
+ Type "Float_" [] -> True
+ _ -> False
+
+inlineAtoms :: Define -> Define
+inlineAtoms x = transformBi h $ rewriteBi g $ rewriteBi f x
+ where
+ tbl = [ (a,b) | LetS a (AtomE b) <- universeBi x ]
+ f (VarA v) = lookup v tbl
+ f _ = Nothing
+ g v = case lookup v tbl of
+ Just (VarA v1) -> Just v1
+ _ -> Nothing
+ h (LetS _ AtomE{}) = NoOpS
+ h s = s
+
+tyEnums :: TyDecl -> [(String,Integer)]
+tyEnums x = zip (sort ss) [ 0 .. ]
+ where
+ ss = [ a | EnumC a <- universeBi x ] ++ [ a | ConC a _ <- universeBi x ]
+
+tyFields :: TyDecl -> [(String,Integer)]
+tyFields x = zip [ a ++ "fld" | FieldT a _ <- universeBi x ] [ 0 .. ]
diff --git a/Pec/LLVM.hs b/Pec/LLVM.hs
new file mode 100644
--- /dev/null
+++ b/Pec/LLVM.hs
@@ -0,0 +1,427 @@
+{-# OPTIONS -Wall #-}
+
+-- The pec embedded compiler
+-- Copyright 2011-2012, Brett Letner
+
+module Pec.LLVM (dModule) where
+
+import Control.Concurrent
+import Data.Char
+import Data.Generics.Uniplate.Data
+import Data.List
+import Data.Maybe
+import Development.Shake.FilePath
+import Grm.Prims
+import Language.LLVM.Abs
+import Numeric
+import Pec.IUtil
+import qualified Language.Pir.Abs as I
+
+data St = St
+ { strings :: [(String,String)]
+ , free_vars :: [String]
+ , enums :: [(String,Integer)]
+ , fields :: [(String,Integer)]
+ , tydecls :: [(String,I.TyDecl)]
+ , defines :: [Define]
+ }
+
+dModule :: FilePath -> I.Module -> IO ()
+dModule outdir m@(I.Module a _ _) = do
+ xs <- readMVar gTyDecls
+ let st0 = St{ strings = ss
+ , enums = concatMap tyEnums $ universeBi xs
+ , free_vars = map vtvar ifvs
+ , fields = concatMap tyFields $ universeBi xs
+ , tydecls = [ (dTypeVar y, z) | (y, z) <- xs ]
+ , defines = []
+ }
+ let ds = map (dTypeD st0) xs
+ let st = st0{ defines = ds }
+ writeFileBinary (joinPath [outdir, fn]) $
+ ppShow $
+ transformBi elimNoOpS $
+ transformBi allocasAtStart $
+ Module $
+ map dStringD ss ++
+ ds ++
+ map dBuiltin builtinTbl ++
+ map (dDeclare st) ifvs ++
+ map (dDefine st) cs
+ where
+ I.Module _ _ cs = transformBi inlineAtoms m
+ ifvs = nub $ concatMap fvsIDefine cs
+ fn = n ++ ".ll"
+ n = case a of
+ "" -> error "unused:dModule"
+ _ -> init a
+ ss = [ (s, "@.str" ++ show i)
+ | (I.StringL s ,i) <- zip (nub $ sort $ universeBi m)
+ [ 0 :: Int .. ]]
+
+dDeclare :: St -> I.TVar -> Define
+dDeclare st x = case ty of
+ PtrT (FunT a bs) -> Declare a v bs
+ _ -> error $ "declare not a function type:" ++ ppShow x
+ where
+ TVar ty v = dTVar st x
+
+dTypeD :: St -> (I.Type, I.TyDecl) -> Define
+dTypeD st (x,y) = TypeD (dTypeVar x) $ dTyDecl st y
+
+dTypeVar :: I.Type -> String
+dTypeVar x0 = '%' : loop x0
+ where
+ loop x = case x of
+ I.Type a [] -> a
+ I.Type a xs ->
+ a ++ "$" ++ concat (intersperse "." $ map loop xs) ++ "$"
+
+dTyDecl :: St -> I.TyDecl -> Type
+dTyDecl st x = case x of
+ I.TyEnum bs -> lengthT bs
+ I.TyRecord bs -> StructT $ map dFieldT bs
+ I.TyTagged bs -> StructT
+ [ lengthT bs
+ , maximumBy (\a b -> compare (sizeT st a) (sizeT st b))
+ [ dType t | I.ConC _ t <- bs ]
+ ]
+
+lengthT :: [a] -> Type
+lengthT = IntT . show . bitsToEncode . genericLength
+
+sizeT :: St -> Type -> Integer
+sizeT st x = case x of
+ VoidT -> 0
+ CharT -> 8
+ FloatT -> 32
+ DoubleT -> 64
+ PtrT{} -> sizeofptr
+ FunT{} -> sizeofptr
+ IntT a -> read a
+ StructT bs -> sum $ map (sizeT st) bs
+ ArrayT a b -> read a * (sizeT st b)
+ UserT a -> case lookup a $ tydecls st of
+ Just b -> sizeT st $ dTyDecl st b
+ Nothing -> error $ "unused:sizeT:UserT:" ++ ppShow x
+ VarArgsT -> error $ "unused:sizeT:VarArgsT:" ++ ppShow x
+
+sizeofptr :: Integer
+sizeofptr = 32
+
+dFieldT :: I.FieldT -> Type
+dFieldT (I.FieldT _ b) = dType b
+
+dVar :: Bool -> String -> String
+dVar is_free v = (if is_free then '@' else '%') : map f v
+ where
+ f c = case c of
+ '~' -> '$'
+ _ -> c
+
+dDefine :: St -> I.Define -> Define
+dDefine st (I.Define a b cs ds) =
+ Define (dType a) (dVar True b) (map (dTVar st) cs)
+ (concatMap (dStmt st) ds)
+
+dStmt :: St -> I.Stmt -> [Stmt]
+dStmt st x = case x of
+ I.LetS a b -> dExp st a b
+ I.StoreS a b -> [ StoreS (dAtom st b) (dTVar st a) ]
+ I.CallS a b -> [ CallS (dTVar st a) (map (dAtom st) b) ]
+ I.SwitchS a b cs -> concat
+ [ [ SwitchS (dAtom st a) l1 $ map (dSwitchAlt st) lcs ]
+ , [ LabelS l1 ]
+ , concatMap (dStmt st) b
+ , [ Br0S l0 ]
+ , concatMap (dSwitchAltBody st l0) lcs
+ , [ LabelS l0 ]
+ ]
+ where
+ l0 = uLbl a
+ l1 = uLbl b
+ lcs = [ (uLbl c, c) | c <- cs ]
+ I.IfS a b c -> concat
+ [ [ BrS (duAtom st a) l1 l2 ]
+ , [ LabelS l1 ]
+ , concatMap (dStmt st) b
+ , [ Br0S l3 ]
+ , [ LabelS l2 ]
+ , concatMap (dStmt st) c
+ , [ Br0S l3 ]
+ , [ LabelS l3 ]
+ ]
+ where
+ l1 = uLbl a
+ l2 = uLbl b
+ l3 = uLbl c
+ I.WhenS a b -> concat
+ [ [ BrS (duAtom st a) l1 l2 ]
+ , [ LabelS l1 ]
+ , concatMap (dStmt st) b
+ , [ Br0S l2 ]
+ , [ LabelS l2 ]
+ ]
+ where
+ l1 = uLbl a
+ l2 = uLbl b
+ I.WhileS a b c -> concat
+ [ [ Br0S l0 ]
+ , [ LabelS l0 ]
+ , concatMap (dStmt st) a
+ , [ BrS (duAtom st b) l1 l2 ]
+ , [ LabelS l1 ]
+ , concatMap (dStmt st) c
+ , [ Br0S l0 ]
+ , [ LabelS l2 ]
+ ]
+ where
+ l0 = uLbl a
+ l1 = uLbl b
+ l2 = uLbl c
+ I.ReturnS a -> [ ReturnS $ dAtom st a ]
+ I.NoOpS -> []
+
+uLbl :: a -> String
+uLbl a = uId a "Lbl"
+
+dSwitchAlt :: St -> (String, I.SwitchAlt) -> SwitchAlt
+dSwitchAlt st (lbl, I.SwitchAlt a _) = SwitchAlt tl lbl
+ where
+ tl = case dTLit st a of
+ TLit (PtrT (FunT b _)) c -> TLit b c -- BAL: Shouldn't base report the correct type here without the need for this fixup?
+ b -> b
+
+dSwitchAltBody :: St -> String -> (String, I.SwitchAlt) -> [Stmt]
+dSwitchAltBody st lbl0 (lbl, I.SwitchAlt _ b) = concat
+ [ [ LabelS lbl ]
+ , concatMap (dStmt st) b
+ , [ Br0S lbl0 ]
+ ]
+
+variantTypes :: St -> Exp -> (Type,Type)
+variantTypes st x = case [ (a, b) | TypeD v (StructT [a,b]) <- defines st, v == v0 ] of
+ [y] -> y
+ _ -> error $ "unused:variantTypes:" ++ ppShow x
+ where
+ IdxE (TVar (PtrT (UserT v0)) _) _ = x
+
+fldE :: TVar -> Integer -> Exp
+fldE a i = IdxE a $ LitA $ TLit (IntT "32") $ NmbrL $ show i
+
+bitcastE :: TVar -> Type -> Exp
+bitcastE = CastE Bitcast
+
+dExp :: St -> I.TVar -> I.Exp -> [Stmt]
+dExp st tv@(I.TVar v t) x = case x of
+ I.CallE (I.TVar "tagv" _) [I.VarA b] ->
+ [ LetS v1 $ fldE (dTVar st b) 0, letS $ LoadE $ TVar (PtrT $ dType t) v1 ]
+ where
+ v1 = uId b "%.tag"
+ I.CallE (I.TVar "un" _) [_, I.VarA c] ->
+ [ LetS v1 e, letS $ bitcastE (TVar (PtrT ta) v1) tb ]
+ where
+ v1 = uId c "%.data"
+ e = fldE (dTVar st c) 1
+ (_,ta) = variantTypes st e
+ tb = dType t
+ I.CallE (I.TVar "mk" a) [I.LitA (I.TLit (I.StringL b) _)] -> fst $ dTag st tv a b
+ I.CallE (I.TVar "mk" a) [I.LitA (I.TLit (I.StringL b) _), c] ->
+ ss0 ++
+ [ LetS datap0 $ fldE tv1 1
+ , LetS datap1 $ bitcastE (TVar (PtrT tb) datap0) (PtrT tc)
+ , StoreS atomc (TVar (PtrT tc) datap1)
+ , s
+ ]
+ where
+ (ss,(tv1,tb)) = dTag st tv a b
+ (ss0, s) = (init ss, last ss)
+ datap0 = uId c "%.data"
+ datap1 = uId datap0 "%.data"
+ atomc = dAtom st c
+ tc = tyAtom atomc
+ I.CallE a [I.VarA b] | isJust mi -> [ letS $ fldE (dTVar st b) $ fromJust mi ]
+ where mi = lookup (vtvar a) $ fields st
+ I.CallE (I.TVar "idx" _) [I.VarA b, c] -> [ letS $ IdxE (dTVar st b) $ dAtom st c ]
+ I.CallE a [b,c] | isBinOp a -> [ letS $ llvmBinOp st a b c ]
+ I.CallE a b -> [ letS $ CallE (dTVar st a) (map (dAtom st) b) ]
+ I.CastE a b -> [ letS $ CastE cast tva tb ]
+ where
+ tva@(TVar ta _) = dTVar st a
+ tb = dType b
+ y = ttvar a
+ sa = sizeT st ta
+ sb = sizeT st tb
+ cast
+ | isSigned y && isFloating b = Sitofp
+ | isUnsigned y && isFloating b = Uitofp
+ | isFloating y && isSigned b = Fptosi
+ | isFloating y && isUnsigned b = Fptoui
+ | isFloating y && isFloating b && sa < sb = Fpext
+ | isFloating y && isFloating b && sa > sb = Fptrunc
+ | isSigned y && isSigned b && sa < sb = Sext
+ | isSigned y && isSigned b && sa > sb = Trunc
+ | isUnsigned y && isUnsigned b && sa < sb = Zext
+ | isUnsigned y && isUnsigned b && sa > sb = Trunc
+ | otherwise = Bitcast
+ I.AllocaE a -> [ letS $ AllocaE $ dType a ]
+ I.LoadE a -> [ letS $ LoadE $ dTVar st a ]
+ I.AtomE a -> [ letS $ AtomE $ dAtom st a ]
+ where
+ letS = LetS (dVar False v)
+
+dTag :: St -> I.TVar -> a -> String -> ([Stmt], (TVar, Type))
+dTag st tv a b =
+ ([ LetS v1 $ AllocaE t
+ , LetS tagp tagfld
+ , StoreS (LitA $ TLit ta $ dEnum st b) (TVar (PtrT ta) tagp)
+ , LetS v0 $ LoadE tv1
+ ], (tv1,tb))
+ where
+ TVar t v0 = dTVar st tv
+ v1 = uId a "%.v"
+ tv1 = TVar (PtrT t) v1
+ tagp = uId b "%.tag"
+ tagfld = fldE tv1 0
+ (ta,tb) = variantTypes st tagfld
+
+duAtom :: St -> I.Atom -> UAtom
+duAtom st = uAtom . dAtom st
+
+llvmBinOp :: St -> I.TVar -> I.Atom -> I.Atom -> Exp
+llvmBinOp st a b c =
+ BinOpE (f ty) (dType ty) (duAtom st b) (duAtom st c)
+ where
+ f = fromJust $ lookup (vtvar a) binOpTbl
+ ty = tatom b
+
+tyAtom :: Atom -> Type
+tyAtom x = case x of
+ LitA (TLit a _) -> a
+ VarA (TVar a _) -> a
+
+uAtom :: Atom -> UAtom
+uAtom x = case x of
+ LitA (TLit _ b) -> LitUA b
+ VarA (TVar _ b) -> VarUA b
+
+dAtom :: St -> I.Atom -> Atom
+dAtom st x = case x of
+ I.LitA a -> LitA $ dTLit st a
+ I.VarA a -> VarA $ dTVar st a
+
+dLit :: St -> I.Type -> I.Lit -> Lit
+dLit st t x = case x of
+ I.StringL a -> case lookup a $ strings st of
+ Just v -> StringL (show $ length a + 1) v
+ Nothing -> error $ "unused:dLit:string"
+ I.NmbrL a
+ | isFloating t -> NmbrL $ show (readNumber a :: Double)
+ | isFloat a -> error $ "non-integral literal:" ++ a
+ | otherwise -> NmbrL $ show (readNumber a :: Integer)
+ I.CharL a -> NmbrL $ show $ ord a
+ I.EnumL a -> dEnum st a
+ I.VoidL -> VoidL
+
+dEnum :: St -> String -> Lit
+dEnum st x = case x of
+ "False_" -> FalseL
+ "True_" -> TrueL
+ _ -> case lookup x $ enums st of
+ Nothing -> error $ "unused:dLit:enum"
+ Just i -> NmbrL $ show i
+
+dTVar :: St -> I.TVar -> TVar
+dTVar st (I.TVar a b) = case lookup a builtinTbl of
+ Just t -> TVar t (dVar True a)
+ Nothing -> TVar (dType b) (dVar (a `elem` (free_vars st ++ builtins)) a)
+
+dBuiltin :: (String, Type) -> Define
+dBuiltin (s, PtrT (FunT a bs)) = Declare a ('@':s) bs
+dBuiltin x = error $ "unused:dBuiltin:" ++ ppShow x
+
+builtinTbl :: [(String, Type)]
+builtinTbl =
+ [ ("printf", PtrT (FunT VoidT [PtrT CharT, VarArgsT])) ]
+
+dTLit :: St -> I.TLit -> TLit
+dTLit st (I.TLit a b) = TLit (dType b) (dLit st b a)
+
+dType :: I.Type -> Type
+dType t@(I.Type a b) = case (a,b) of
+ ("Ptr_", [c]) -> PtrT (dType c)
+ ("Void_", []) -> VoidT
+ ("I_",_) -> IntT $ nCnt b
+ ("W_",_) -> IntT $ nCnt b
+ ("Fun_", ts) -> PtrT (FunT (dType $ last ts) (map dType $ init ts))
+ ("Array_", [c,d]) -> ArrayT (nCnt [c]) (dType d)
+ ("Float_", []) -> FloatT
+ ("Double_", []) -> DoubleT
+ ("Char_", []) -> CharT
+ _ -> UserT $ dTypeVar t
+
+fSOrU :: a -> a -> a -> I.Type -> a
+fSOrU a b c t
+ | isFloating t = a
+ | isSigned t = b
+ | otherwise = c
+
+fOrN :: a -> a -> I.Type -> a
+fOrN a b t
+ | isFloating t = a
+ | otherwise = b
+
+binOpTbl :: [(String, I.Type -> BinOp)]
+binOpTbl =
+ [ ("eq", \_ -> Icmp Equ)
+ , ("ne", \_ -> Icmp Neq)
+ , ("gt", fSOrU (Fcmp Ogt) (Icmp Sgt) (Icmp Ugt))
+ , ("gte", fSOrU (Fcmp Oge) (Icmp Sge) (Icmp Uge))
+ , ("lt", fSOrU (Fcmp Olt) (Icmp Slt) (Icmp Ult))
+ , ("lte", fSOrU (Fcmp Ole) (Icmp Sle) (Icmp Ule))
+ , ("add", fOrN Fadd Add)
+ , ("sub", fOrN Fsub Sub)
+ , ("mul", fOrN Fmul Mul)
+ , ("div", fSOrU Fdiv Sdiv Udiv)
+ , ("rem", fSOrU Frem Srem Urem)
+ , ("shl", \_ -> Shl)
+ , ("shr", \_ -> Lshr)
+ , ("band", \_ -> And)
+ , ("bor", \_ -> Or)
+ , ("bxor", \_ -> Xor)
+ , ("bnot", \_ -> error $ "todo:implement binary not in LLVM") -- BAL
+ , ("and", \_ -> error $ "todo:implement boolean and in LLVM") -- BAL:doesn't this get desugared?
+ , ("or", \_ -> error $ "todo:implement boolean or in LLVM") -- BAL:doesn't this get desugared?
+ ]
+
+dStringD :: (String, Lident) -> Define
+dStringD (s,v) = StringD v (show $ 1 + length s) $ concatMap const_char s
+
+const_char :: Char -> String
+const_char c
+ | c < ' ' || c > '~' || c == '\\' = encode_char c
+ | otherwise = [c]
+
+encode_char :: Enum a => a -> String
+encode_char c =
+ '\\' : (if i <= 0xf then "0" else "") ++ map toUpper (showHex i "")
+ where i = fromEnum c
+
+allocasAtStart :: Define -> Define -- also removes unused allocas
+allocasAtStart (Define a b cs ds) = Define a b cs $
+ [ s | s@(LetS v AllocaE{}) <- universeBi ds, v `elem` universeBi ds1 ]
+ ++ ds1
+ where
+ ds1 = transformBi f ds
+ f :: Stmt -> Stmt
+ f s
+ | isAllocaS s = NoOpS
+ | otherwise = s
+allocasAtStart x = x
+
+isAllocaS :: Stmt -> Bool
+isAllocaS (LetS _ AllocaE{}) = True
+isAllocaS _ = False
+
+elimNoOpS :: Module -> Module
+elimNoOpS = transformBi (filter ((/=) NoOpS))
diff --git a/Pec/Makefile b/Pec/Makefile
deleted file mode 100644
--- a/Pec/Makefile
+++ /dev/null
@@ -1,2 +0,0 @@
-clean :
- rm -f *~ *.hi *.o
diff --git a/Pec/PUtil.hs b/Pec/PUtil.hs
new file mode 100644
--- /dev/null
+++ b/Pec/PUtil.hs
@@ -0,0 +1,91 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- The pec embedded compiler
+-- Copyright 2011-2012, Brett Letner
+
+module Pec.PUtil where
+
+import Control.Monad
+import Data.Data
+import Data.Generics.Uniplate.Data
+import Data.List
+import Development.Shake.FilePath
+import Distribution.Text
+import Grm.Layout
+import Grm.Lex
+import Grm.Prims
+import Language.Pec.Abs
+import Language.Pec.Abs as P
+import Language.Pec.Par
+import Paths_pec
+import System.Console.CmdArgs
+import qualified Language.Pds.Abs as D
+
+copyright :: String
+copyright = "(C) Brett Letner 2011-2012"
+
+parse_pec :: FilePath -> IO (P.Module Point)
+parse_pec fn = do
+ ts <- P.grmLexFilePath fn
+ let m@(P.Module _ a _ _ _) = grmParse $ layout $ filter notWSToken ts
+ if ((splitDirectories $ dropExtension $ normalise fn) `has_suffix`
+ (unqual $ ppShow a))
+ then return m
+ else error $ "module name mismatch:" ++ fn ++ ":" ++ ppShow a
+
+has_suffix :: Eq a => [a] -> [a] -> Bool
+has_suffix a b = drop (length a - length b) a == b
+
+imports :: D.Module -> [String]
+imports (D.Module _ _ xs _ _ _) = [ a | D.ImportD a _ <- xs ]
+
+modid :: D.Module -> String
+modid (D.Module n _ _ _ _ _) = n
+
+counts :: P.Module Point -> [Integer]
+counts (P.Module _ _ _ _ xs) = nub $
+ [ genericLength (a :: [P.ConC Point])
+ | P.TyTagged _ a <- universeBi xs ] ++
+ [ genericLength (a :: [P.Exp Point]) | ArrayE _ a <- universeBi xs ] ++
+ [ pcount a | TyCount _ a <- universeBi xs ] ++
+ [ pcount a | CountE _ a <- universeBi xs ]
+
+pcount :: Count Point -> Integer
+pcount (Count _ i) = read i
+
+qual_to_und :: String -> String
+qual_to_und = map f
+ where f c = if c == '.' then '_' else c
+
+und_to_path :: String -> String
+und_to_path = joinPath . splitBy ((==) '_')
+
+unqual :: String -> [String]
+unqual = splitBy ((==) '.')
+
+qual :: [String] -> String
+qual = concat . intersperse "."
+
+splitBy :: (a -> Bool) -> [a] -> [[a]]
+splitBy p = loop [] []
+ where
+ loop [] ys [] = filter (not . null) $ reverse ys
+ loop xs ys [] = loop [] (reverse xs : ys) []
+ loop xs ys (c:cs)
+ | p c = loop [] (reverse xs : ys) cs
+ | otherwise = loop (c:xs) ys cs
+
+summarize :: String -> String
+summarize prog = prog ++ " v" ++ display version ++ ", " ++ copyright
+
+readFileDeps :: FilePath -> IO ([String],[Integer])
+readFileDeps = liftM read . readFile
+
+writeFileDeps :: FilePath -> ([String],[Integer]) -> IO ()
+writeFileDeps fn = writeFileBinary fn . show
+
+data Arch = C | LLVM deriving (Show, Data, Typeable)
+
+instance Default Arch where
+ def = C
diff --git a/Pir.grm b/Pir.grm
new file mode 100644
--- /dev/null
+++ b/Pir.grm
@@ -0,0 +1,68 @@
+data Module
+ | Module "module" uident ImportList DefineList
+
+data Import | Import "import" uident
+
+data Define
+ | Define "define" Type lident "(" TVarList ")" "=" "{" StmtList "}"
+
+data Stmt
+ | LetS TVar "=" Exp
+ | StoreS TVar ":=" Atom
+ | CallS "call" TVar "(" AtomList ")"
+ | SwitchS "switch" Atom "{" StmtList "}" "{" SwitchAltList "}"
+ | IfS "if" Atom "{" StmtList "}" "{" StmtList "}"
+ | WhenS "when" Atom "{" StmtList "}"
+ | WhileS "while" "{" StmtList "}" Atom "{" StmtList "}"
+ | ReturnS "return" Atom
+ | NoOpS "noop"
+
+data Exp
+ | CallE TVar "(" AtomList ")"
+ | CastE "cast" TVar Type
+ | AllocaE "alloca" Type
+ | LoadE "load" "(" TVar ")"
+ | AtomE Atom
+
+data Atom
+ | LitA TLit
+ | VarA TVar
+
+data SwitchAlt | SwitchAlt TLit "->" "{" StmtList "}"
+
+data Lit
+ | StringL string
+ | NmbrL number
+ | CharL char
+ | EnumL uident
+ | VoidL
+
+data TyDecl
+ | TyEnum "enum" EnumCList
+ -- | TyArray "[" integer "]" Type
+ | TyRecord "record" "{" FieldTList "}"
+ | TyTagged "tagged" ConCList
+
+data TVar | TVar lident "::" Type
+
+data TLit | TLit Lit "::" Type
+
+data FieldT | FieldT uident "::" Type
+
+data ConC | ConC uident Type
+
+data Type | Type uident "(" TypeList ")"
+
+data EnumC | EnumC uident
+
+list ConCList ConC nonempty separator "|" horiz
+list FieldTList FieldT nonempty separator "," horiz
+list EnumCList EnumC nonempty separator "|" horiz
+list TypeList Type empty separator "," horiz
+list ExpList Exp nonempty separator "," horiz
+list AtomList Atom nonempty separator "," horiz
+list TVarList TVar nonempty separator "," horiz
+list SwitchAltList SwitchAlt empty terminator ";" vert
+list StmtList Stmt empty terminator ";" vert
+list DefineList Define empty terminator ";" vert
+list ImportList Import empty terminator ";" vert
diff --git a/README b/README
--- a/README
+++ b/README
@@ -1,37 +1,42 @@
-Introducing the pec language and pec embedded compiler.
-
-The intent of pec is to provide a drop-in replacement for C, but with
-modern language features. Pec is a procedural language with a
-functional/declarative feel. Programming in pec is very similar to
-monadic programming in Haskell. The primary use case for pec is to
-provide a productive environment for writing safe, efficient, embedded
-applications.
-
-Feature list
- - Easy C integration
- - No garbage collection
- - Strong typing with Hindley-Milner type inference
- - Safe pointers, no indexing out of bounds
- - Variants, vectors, tuples, records, arbitrary sized integers
- - User defined, polymorphic data structures
- - Parametric polymorphism, ad-hoc polymorphism, laziness (strict by
- default), user-defined operators, etc.
- - Modules
- - Compiles to LLVM (C planned)
- - Haskell-ish syntax/layout
- - BSD license
-
-Pec (the language and the compiler) is in the alpha stage of
-development. The compiler is implemented in Haskell and has a very
-small codebase (thanks to several existing Haskell tools/libraries).
-
-You can download and install pec via cabal or access the git
-repository on github (git@github.com:stevezhee/pec.git). You'll need
-to install the llvm tools (http://llvm.org/) to build the examples.
-
-Any feedback on the design and/or implementation of pec would be
-greatly appreciated :)
-
-Thanks,
-Brett
-brettletner at gmail dot com
+Introducing the pec language and pec embedded compiler.
+
+The intent of pec is to provide a drop-in replacement for C, but with
+modern language features. Pec is a procedural language with a
+functional/declarative feel. Programming in pec is very similar to
+monadic programming in Haskell. The primary use case for pec is to
+provide a productive environment for writing safe, efficient, embedded
+applications.
+
+Feature list
+ - Easy C integration
+ - No garbage collection
+ - Strong typing with Hindley-Milner type inference
+ - Safe pointers, no indexing out of bounds
+ - Variants, arrays, tuples, records, arbitrary sized integers
+ - User defined, polymorphic data structures
+ - Parametric polymorphism, limited ad-hoc polymorphism
+ - Modules
+ - Compiles to C and LLVM
+ - Haskell-ish syntax/layout
+ - BSD license
+
+Building
+ - type 'make'
+ - resolve all hackage dependencies
+ - type 'make' again
+ - go and get a cup of coffee :)
+
+Pec (the language and the compiler) is in the alpha stage of
+development. The compiler is implemented in Haskell and has a very
+small codebase (thanks to several existing Haskell tools/libraries).
+
+You can download and install pec via cabal or access the git
+repository on github (git@github.com:stevezhee/pec.git). You'll need
+to have a c compiler installed to build the examples.
+
+Any feedback on the design and/or implementation of pec would be
+greatly appreciated :)
+
+Thanks,
+Brett
+brettletner at gmail dot com
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,8 +1,6 @@
-#! /usr/bin/env runhaskell
-
--- The pec embedded compiler
--- Copyright 2011, Brett Letner
-
-import Distribution.Simple
-
-main = defaultMain
+-- The pec embedded compiler
+-- Copyright 2011-2012, Brett Letner
+
+import Distribution.Simple
+
+main = defaultMain
diff --git a/THANKS b/THANKS
--- a/THANKS
+++ b/THANKS
@@ -1,16 +1,17 @@
-The developement of pec would not have been possible without the following free software:
- - ghc http://haskell.org/ghc/
- - llvm http://llvm.org/
- - bnfc http://www.cse.chalmers.se/research/group/Language-technology/BNFC/
- - happy http://haskell.org/happy/
- - alex http://haskell.org/alex/
- - hackage modules http://hackage.haskell.org/packages/hackage.html
-
-In addition I'd like to thank the following people...
-
-Sigbjorn Finne, Andy Gill, Iavor Diatchki, Lee Pike, Isaac
-Potoczny-Jones, Brian Adams, Travis Rhoades, Mike Letner, Brevin
-Letner, and my family
-
-Thanks guys!
-
+The developement of pec would not have been possible without the following free software:
+ - ghc http://haskell.org/ghc/
+ - llvm http://llvm.org/
+ - gcc http://gcc.gnu.org/
+ - bnfc http://www.cse.chalmers.se/research/group/Language-technology/BNFC/
+ - happy http://haskell.org/happy/
+ - alex http://haskell.org/alex/
+ - hackage modules http://hackage.haskell.org/packages/hackage.html
+
+In addition I'd like to thank the following people...
+
+Sigbjorn Finne, Andy Gill, Iavor Diatchki, Lee Pike, Isaac
+Potoczny-Jones, Brian Adams, Travis Rhoades, Mike Letner, Brevin
+Letner, and my family
+
+Thanks guys!
+
diff --git a/TODO b/TODO
--- a/TODO
+++ b/TODO
@@ -1,55 +1,73 @@
-todo
-- do language design doc
-- do compiler architecture doc
-- add qualified names
-- make read only pointers
-- "Show" instances
-- "Eq" instances
-- allow operators in export lists
-- add import "as"
-- add import list(?)
-- make the inline Haskell code (i.e. '>') play nice with comments
-- implement downward closures(?)
-- properly create .ll files (i.e. with declare statements)
-- implement puts that doesn't tack on a newline
-- haddock'ize modules
-- write more example code (project euler or language shootout)
-- add -i flag to search other directories
-- add c code generation
-- report llvm bug
-- add state machine optimization(?)
-- don't rebuild files that haven't changed (unfortunately the istrings complicate things)
-- add warning when _ is used as a name
-- add check to ensure that variables are SSA
-- add check to prevent recursion
-
-done
-- datatype: string buffer
-- datatype: stack
-- implement prelude/ other library functions
-- generate Counts, etc. in separate files
-- get test infrastructure in place
-- get coverage infrastructure in place
-- make Bool work in case exp (make it constructed like all the rest)
-- get arrays working
-- add ascription
-- fix operator precedence
-- add top level type declarations for functions
-- make code generation easier to read/debug
-- make pretty printer robust
-- call external Haskell pretty-printer for generated code
-- consider removing module keyword. Decided to keep it. That way we can process streams, not just files.
-- add the ability to generate arbitrary sized integers and words (e.g. I16, W64) (add boilerplate generation to pec.hs)
-- add exports
-- get variants working
-- get tuples working
-- get records working
-- added arithmetic ops
-- added bitwise ops
-- make top level (non-procedure) values work
-- add array initializer that takes a count and a value
-- implement function pointers
-- take all non-essential things out of Base and put them into pec libraries
-- make library implementation easier by integrating haskell code into .pec files
-- create separate .ll files and cat them together
-- add rebuild all flag
+todo
+- implement binding to c code and c libs
+- have pec manage the namespaces, not ghc
+- have pec do the type inference, not ghc
+- Print, Show, Eq instances
+- implement read-eval-print-loop interpreter (REPL)
+- make libraries consistently use underscore (or camel case)
+- make sure build deps are correct
+- allow operators in export lists
+- add import list(?)
+- implement downward closures(?)
+- haddock'ize modules
+- write more example code (project euler,language shootout,etc.)
+- add state machine optimization(?)
+- add warning when _ is used as a name
+- add check to ensure that variables are SSA
+- add check to prevent recursion (what about function pointers?)
+- allow for _ <- foo () (not just b <- foo ())
+- improve compiler coverage
+- revisit llvm operators do determine correct flags, e.g. nuw, exact
+- implement unfold for containers
+
+done
+- update docs for release
+- release grm
+- properly create .ll files (i.e. with declare statements)
+- do language design doc
+- do compiler architecture doc
+- add/reinstate llvm code generation
+- implement filter, map, empty, fold, etc. for all containers
+- add deps/building to grm
+- Deque printing is not working
+- error if module name doesn't match filename
+- add a way to print ints
+- rename files to make more consistent
+- implement puts that doesn't tack on a newline
+- add -i flag to search other directories
+- use & and && instead of &&& and && by changing the name of and and band(?), same for or...
+- don't rebuild files that haven't changed (unfortunately the istrings complicate things)
+- add c code generation
+- make the inline Haskell code (i.e. '>') play nice with comments
+- add import "as"
+- add qualified names
+- make read only pointers
+- datatype: string buffer
+- datatype: stack
+- implement prelude/ other library functions
+- generate Counts, etc. in separate files
+- get test infrastructure in place
+- get coverage infrastructure in place
+- make Bool work in case exp (make it constructed like all the rest)
+- get arrays working
+- add ascription
+- fix operator precedence
+- add top level type declarations for functions
+- make code generation easier to read/debug
+- make pretty printer robust
+- call external Haskell pretty-printer for generated code
+- consider removing module keyword. Decided to keep it. That way we can process streams, not just files.
+- add the ability to generate arbitrary sized integers and words (e.g. I16, W64) (add boilerplate generation to pec.hs)
+- add exports
+- get variants working
+- get tuples working
+- get records working
+- added arithmetic ops
+- added bitwise ops
+- make top level (non-procedure) values work
+- add array initializer that takes a count and a value
+- implement function pointers
+- take all non-essential things out of Base and put them into pec libraries
+- make library implementation easier by integrating haskell code into .pec files
+- create separate .ll files and cat them together
+- add rebuild all flag
diff --git a/dist/build/pec/pec-tmp/Language/Pec/Lex.hs b/dist/build/pec/pec-tmp/Language/Pec/Lex.hs
deleted file mode 100644
--- a/dist/build/pec/pec-tmp/Language/Pec/Lex.hs
+++ /dev/null
@@ -1,361 +0,0 @@
-{-# OPTIONS -fglasgow-exts -cpp #-}
-{-# LINE 3 "Language/Pec/Lex.x" #-}
-
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
-module Language.Pec.Lex where
-
-
-
-
-#if __GLASGOW_HASKELL__ >= 603
-#include "ghcconfig.h"
-#elif defined(__GLASGOW_HASKELL__)
-#include "config.h"
-#endif
-#if __GLASGOW_HASKELL__ >= 503
-import Data.Array
-import Data.Char (ord)
-import Data.Array.Base (unsafeAt)
-#else
-import Array
-import Char (ord)
-#endif
-#if __GLASGOW_HASKELL__ >= 503
-import GHC.Exts
-#else
-import GlaExts
-#endif
-alex_base :: AlexAddr
-alex_base = AlexA# "\xf8\xff\xff\xff\xd7\xff\xff\xff\xfd\xff\xff\xff\xe5\x00\x00\x00\xfe\xff\xff\xff\x0b\x01\x00\x00\xda\xff\xff\xff\x2e\x01\x00\x00\xe0\xff\xff\xff\x51\x01\x00\x00\x00\x00\x00\x00\x74\x01\x00\x00\xe1\xff\xff\xff\x97\x01\x00\x00\xe2\xff\xff\xff\xba\x01\x00\x00\xdd\x01\x00\x00\xe3\xff\xff\xff\x00\x02\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x23\x02\x00\x00\x46\x02\x00\x00\x9b\x02\x00\x00\xbe\x02\x00\x00\xe1\x02\x00\x00\x36\x03\x00\x00\x4c\x00\x00\x00\x5f\x00\x00\x00\x69\x00\x00\x00\x75\x00\x00\x00\xcb\x00\x00\x00\x57\x02\x00\x00\x54\x03\x00\x00\x24\x04\x00\x00\xf4\x04\x00\x00\xc4\x05\x00\x00\x94\x06\x00\x00\x64\x07\x00\x00\x43\x08\x00\x00\x61\x02\x00\x00\x61\x08\x00\x00\x00\x00\x00\x00\xfb\x00\x00\x00\x04\x01\x00\x00\x81\x02\x00\x00\x00\x00\x00\x00\xe7\xff\xff\xff\x31\x00\x00\x00\xf0\x00\x00\x00"#
-
-alex_table :: AlexAddr
-alex_table = AlexA# "\x00\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x06\x00\xff\xff\xff\xff\x02\x00\x0e\x00\x0e\x00\x0c\x00\x0e\x00\x2e\x00\x00\x00\x08\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x27\x00\x2b\x00\x17\x00\x27\x00\x27\x00\x27\x00\x30\x00\x14\x00\x14\x00\x27\x00\x27\x00\x14\x00\x1a\x00\x15\x00\x07\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x18\x00\x14\x00\x19\x00\x16\x00\x27\x00\x27\x00\x16\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x14\x00\x27\x00\x14\x00\x27\x00\x23\x00\xff\xff\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x14\x00\x16\x00\x14\x00\x27\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x00\x13\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1d\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x00\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\xff\xff\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x20\x00\x00\x00\x00\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\xff\xff\x05\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\xff\xff\x05\x00\x05\x00\x00\x00\x05\x00\x05\x00\x05\x00\xff\xff\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x05\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x05\x00\x05\x00\x00\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x05\x00\x00\x00\x05\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x2f\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x2d\x00\x10\x00\x27\x00\x00\x00\x27\x00\x27\x00\x03\x00\x2f\x00\x00\x00\x2d\x00\x05\x00\x00\x00\x05\x00\x2f\x00\x00\x00\x00\x00\x05\x00\x27\x00\x05\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x05\x00\x27\x00\x12\x00\x27\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x27\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x12\x00\x27\x00\x12\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x12\x00\x00\x00\x12\x00\x12\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x27\x00\x12\x00\x27\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x12\x00\x00\x00\x12\x00\x12\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x27\x00\x27\x00\x00\x00\x27\x00\x16\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x12\x00\x27\x00\x12\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x27\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x2c\x00\x27\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x2c\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x27\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x27\x00\x16\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x27\x00\x27\x00\x00\x00\x16\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x27\x00\x00\x00\x27\x00\x27\x00\x16\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x00\x00\x27\x00\x22\x00\x27\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x29\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x29\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x00\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x00\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x00\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x29\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x00\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x00\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x00\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x26\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x27\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x27\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x00\x00\x00\x00\x00\x00\x27\x00\x29\x00\x27\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x00\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x00\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00"#
-
-alex_check :: AlexAddr
-alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2f\x00\x0a\x00\x0a\x00\x2f\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x27\x00\xff\xff\x2f\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x0a\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x0a\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x0a\x00\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x5c\x00\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x5c\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x6e\x00\xff\xff\x5c\x00\x7c\x00\xff\xff\x7e\x00\x74\x00\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x22\x00\x5e\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x7c\x00\xff\xff\x7e\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\x5c\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x7c\x00\xff\xff\x7e\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x7c\x00\x5f\x00\x7e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x7c\x00\x5f\x00\x7e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"#
-
-alex_deflt :: AlexAddr
-alex_deflt = AlexA# "\xff\xff\xff\xff\x04\x00\x04\x00\x04\x00\x04\x00\xff\xff\xff\xff\x11\x00\x11\x00\xff\xff\xff\xff\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2c\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x2f\x00\xff\xff"#
-
-alex_accept = listArray (0::Int,49) [[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[],[(AlexAcc (alex_action_7))],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[],[(AlexAcc (alex_action_7))],[],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_7))],[],[(AlexAcc (alex_action_7))],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[],[(AlexAcc (alex_action_8))],[],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_11))],[],[],[],[(AlexAcc (alex_action_12))],[],[],[]]
-{-# LINE 41 "Language/Pec/Lex.x" #-}
-
-
-tok f p s = f p s
-
-share :: String -> String
-share = id
-
-data Tok =
- TS !String !Int -- reserved words and symbols
- | TL !String -- string literals
- | TI !String -- integer literals
- | TV !String -- identifiers
- | TD !String -- double precision float literals
- | TC !String -- character literals
- | T_Frac !String
- | T_Uident !String
- | T_Lident !String
- | T_USym !String
- | T_Number !String
- | T_Count !String
-
- deriving (Eq,Show,Ord)
-
-data Token =
- PT Posn Tok
- | Err Posn
- deriving (Eq,Show,Ord)
-
-tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
-tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
-tokenPos _ = "end of file"
-
-posLineCol (Pn _ l c) = (l,c)
-mkPosToken t@(PT p _) = (posLineCol p, prToken t)
-
-prToken t = case t of
- PT _ (TS s _) -> s
- PT _ (TL s) -> s
- PT _ (TI s) -> s
- PT _ (TV s) -> s
- PT _ (TD s) -> s
- PT _ (TC s) -> s
- PT _ (T_Frac s) -> s
- PT _ (T_Uident s) -> s
- PT _ (T_Lident s) -> s
- PT _ (T_USym s) -> s
- PT _ (T_Number s) -> s
- PT _ (T_Count s) -> s
-
-
-data BTree = N | B String Tok BTree BTree deriving (Show)
-
-eitherResIdent :: (String -> Tok) -> String -> Tok
-eitherResIdent tv s = treeFind resWords
- where
- treeFind N = tv s
- treeFind (B a t left right) | s < a = treeFind left
- | s > a = treeFind right
- | s == a = t
-
-resWords = b "as" 17 (b ";" 9 (b "->" 5 (b ")" 3 (b "(" 2 (b "#" 1 N N) N) (b "," 4 N N)) (b ".." 7 (b "." 6 N N) (b "::" 8 N N))) (b "Array" 13 (b "=" 11 (b "<-" 10 N N) (b "@" 12 N N)) (b "]" 15 (b "[" 14 N N) (b "all" 16 N N)))) (b "let" 25 (b "exports" 21 (b "case" 19 (b "branch" 18 N N) (b "do" 20 N N)) (b "import" 23 (b "extern" 22 N N) (b "in" 24 N N))) (b "where" 29 (b "of" 27 (b "module" 26 N N) (b "type" 28 N N)) (b "|" 31 (b "{" 30 N N) (b "}" 32 N N))))
- where b s n = let bs = id s
- in B bs (TS bs n)
-
-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
- '"':[] -> []
- 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 AlexInput = (Posn, -- current position,
- Char, -- previous 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')
-
-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
-alexGetChar (p, _, s) =
- case s of
- [] -> Nothing
- (c:s) ->
- let p' = alexMove p c
- in p' `seq` Just (c, (p', c, s))
-
-alexInputPrevChar :: AlexInput -> Char
-alexInputPrevChar (p, c, s) = c
-
-alex_action_3 = tok (\p s -> PT p (eitherResIdent (TV . share) s))
-alex_action_4 = tok (\p s -> PT p (eitherResIdent (T_Frac . share) s))
-alex_action_5 = tok (\p s -> PT p (eitherResIdent (T_Uident . share) s))
-alex_action_6 = tok (\p s -> PT p (eitherResIdent (T_Lident . share) s))
-alex_action_7 = tok (\p s -> PT p (eitherResIdent (T_USym . share) s))
-alex_action_8 = tok (\p s -> PT p (eitherResIdent (T_Number . share) s))
-alex_action_9 = tok (\p s -> PT p (eitherResIdent (T_Count . share) s))
-alex_action_10 = tok (\p s -> PT p (eitherResIdent (TV . share) s))
-alex_action_11 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s))
-alex_action_12 = tok (\p s -> PT p (TC $ share s))
-{-# LINE 1 "templates/GenericTemplate.hs" #-}
-{-# LINE 1 "templates/GenericTemplate.hs" #-}
-{-# LINE 1 "" #-}
-{-# LINE 1 "" #-}
-{-# LINE 1 "templates/GenericTemplate.hs" #-}
--- -----------------------------------------------------------------------------
--- 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
-
-{-# LINE 35 "templates/GenericTemplate.hs" #-}
-
-{-# LINE 45 "templates/GenericTemplate.hs" #-}
-
-
-data AlexAddr = AlexA# Addr#
-
-#if __GLASGOW_HASKELL__ < 503
-uncheckedShiftL# = shiftL#
-#endif
-
-{-# INLINE alexIndexInt16OffAddr #-}
-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
- indexInt16OffAddr# arr off
-#endif
-
-
-
-
-
-{-# INLINE alexIndexInt32OffAddr #-}
-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
- indexInt32OffAddr# arr off
-#endif
-
-
-
-
-
-#if __GLASGOW_HASKELL__ < 503
-quickIndex arr i = arr ! i
-#else
--- GHC >= 503, unsafeAt is available from Data.Array.Base.
-quickIndex = unsafeAt
-#endif
-
-
-
-
--- -----------------------------------------------------------------------------
--- Main lexing routines
-
-data AlexReturn a
- = AlexEOF
- | AlexError !AlexInput
- | AlexSkip !AlexInput !Int
- | AlexToken !AlexInput !Int a
-
--- alexScan :: AlexInput -> StartCode -> AlexReturn a
-alexScan input (I# (sc))
- = alexScanUser undefined input (I# (sc))
-
-alexScanUser user input (I# (sc))
- = case alex_scan_tkn user input 0# input sc AlexNone of
- (AlexNone, input') ->
- case alexGetChar input of
- Nothing ->
-
-
-
- AlexEOF
- Just _ ->
-
-
-
- AlexError input'
-
- (AlexLastSkip input len, _) ->
-
-
-
- AlexSkip input len
-
- (AlexLastAcc k input len, _) ->
-
-
-
- AlexToken input len 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` (I# (s)))
- in
- new_acc `seq`
- case alexGetChar input of
- Nothing -> (new_acc, input)
- Just (c, new_input) ->
-
-
-
- let
- base = alexIndexInt32OffAddr alex_base s
- (I# (ord_c)) = ord c
- offset = (base +# ord_c)
- check = alexIndexInt16OffAddr alex_check offset
-
- new_s = if (offset >=# 0#) && (check ==# ord_c)
- then alexIndexInt16OffAddr alex_table offset
- else alexIndexInt16OffAddr alex_deflt s
- in
- case new_s of
- -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 (len +# 1#)
- new_input new_s new_acc
-
- where
- check_accs [] = last_acc
- check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))
- check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))
- check_accs (AlexAccPred a pred : rest)
- | pred user orig_input (I# (len)) input
- = AlexLastAcc a input (I# (len))
- check_accs (AlexAccSkipPred pred : rest)
- | pred user orig_input (I# (len)) input
- = AlexLastSkip input (I# (len))
- check_accs (_ : rest) = check_accs rest
-
-data AlexLastAcc a
- = AlexNone
- | AlexLastAcc a !AlexInput !Int
- | AlexLastSkip !AlexInput !Int
-
-data AlexAcc a user
- = AlexAcc a
- | AlexAccSkip
- | AlexAccPred a (AlexAccPred user)
- | AlexAccSkipPred (AlexAccPred 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
-
---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _
-alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input
-
---alexRightContext :: Int -> AlexAccPred _
-alexRightContext (I# (sc)) user _ _ input =
- case alex_scan_tkn user input 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.
-
--- used by wrappers
-iUnbox (I# (i)) = i
diff --git a/lib/Data/Array.pec b/lib/Data/Array.pec
new file mode 100644
--- /dev/null
+++ b/lib/Data/Array.pec
@@ -0,0 +1,90 @@
+module Data.Array
+
+exports
+ Data.Array.max_idx
+ apply_at_idx
+ array
+ find
+ find_idx
+ fold
+ foreach
+ foreach_idx
+ map
+ map_idx
+ unsafe_find_idx
+ unsafe_foreach_idx
+ put
+ any
+
+imports
+ Prelude
+
+where
+
+// BAL: change Ptr to Load Pointer where applicable
+
+map :: (a -> b) -> Ptr (Array #cnt a) -> Array #cnt b
+map f p => do
+ q = unsafe_alloca
+ foreach_idx (map_idx f p q) p
+ load q
+
+map_idx ::
+ (a -> b) -> Ptr (Array #cnt a) -> Ptr (Array #cnt b) -> Idx #cnt -> ()
+map_idx f p q i => q[i] <- f @p[i]
+
+apply_at_idx :: { Load p } =>
+ (Pointer p a -> ()) -> Pointer p (Array #cnt a) -> Idx #cnt -> ()
+apply_at_idx f p i => f p[i]
+
+find :: (a -> Bool) -> Ptr (Array #cnt a) -> Maybe (Ptr a)
+find f p => case new (find_idx f p) of
+ Nothing -> Nothing
+ Just i -> Just p[@i]
+
+any :: (a -> Bool) -> Ptr (Array #cnt a) -> Bool
+any f p => case new (find_idx f p) of
+ Nothing -> False
+ Just _ -> True
+
+find_idx :: (a -> Bool) -> Ptr (Array #cnt a) -> Maybe (Idx #cnt)
+find_idx f p => unsafe_find_idx (count p) f p
+
+unsafe_find_idx ::
+ W32 -> (a -> Bool) -> Ptr (Array #cnt a) -> Maybe (Idx #cnt)
+unsafe_find_idx j f p => do
+ i = new (0 :: W32)
+ while ((@i < j) && (not (f @p[unsafe_to_idx @i]))) (inc i)
+ branch
+ @i == j -> Nothing
+ | Just (unsafe_to_idx @i)
+
+fold :: { Load p } => (b -> a -> b) -> b -> Pointer p (Array #cnt a) -> b
+fold f b arr => do
+ pb = new b
+ foreach (fold_ptr f pb) arr
+ @pb
+
+array :: #cnt -> a -> Array #cnt a // BAL: leave the unused count param?
+array _ a => do
+ arr = unsafe_alloca
+ foreach (flip store a) arr
+ @arr
+
+foreach :: { Load p } =>
+ (Pointer p a -> ()) -> Pointer p (Array #cnt a) -> ()
+foreach f p => foreach_idx (apply_at_idx f p) p
+
+foreach_idx :: { Load p } =>
+ (Idx #cnt -> ()) -> Pointer p (Array #cnt a) -> ()
+foreach_idx f p => unsafe_foreach_idx (count p) f
+
+unsafe_foreach_idx :: W32 -> (Idx #cnt -> ()) -> ()
+unsafe_foreach_idx j f => times j (\i -> f (unsafe_to_idx i))
+
+max_idx :: Pointer p (Array #cnt a) -> Idx #cnt
+max_idx _ => idx_max
+
+put :: { Load p } =>
+ (a -> ()) -> Pointer p (Array #cnt a) -> ()
+put f p => putBrackets (foreach (putElem f) p)
diff --git a/lib/Data/Deque.pec b/lib/Data/Deque.pec
new file mode 100644
--- /dev/null
+++ b/lib/Data/Deque.pec
@@ -0,0 +1,167 @@
+module Data.Deque
+
+exports
+ Deque
+ any
+ del_back
+ deque
+ empty
+ filter
+ find
+ find_idx
+ fold
+ foreach
+ foreach_idx
+ is_empty
+ is_full
+ map
+ pop_back
+ pop_front
+ push_back
+ push_front
+ put
+
+imports
+ Prelude
+ Data.Array as A
+
+where
+
+type Deque cnt a =
+ { back :: Idx #cnt
+ , height :: W32
+ , data :: Array #cnt a
+ }
+
+filter :: (a -> Bool) -> Ptr (Deque #cnt a) -> ()
+filter f p => do
+ h = @p.height
+ empty p
+ unsafe_foreach_idx (back p) h (filter_elem f p)
+
+filter_elem :: (a -> Bool) -> Ptr (Deque #cnt a) -> Idx #cnt -> ()
+filter_elem f p i => do
+ a = @p.data[i]
+ when (f a) (assert (push_front a p))
+
+any :: { Load p } => (a -> Bool) -> Pointer p (Deque #cnt a) -> Bool
+any f p => case new (find_idx f p) of
+ Nothing -> False
+ Just _ -> True
+
+find :: { Load p } =>
+ (a -> Bool) -> Pointer p (Deque #cnt a) -> Maybe (Pointer p a)
+find f p => case new (find_idx f p) of
+ Nothing -> Nothing
+ Just i -> Just p.data[@i]
+
+find_idx :: { Load p } =>
+ (a -> Bool) -> Pointer p (Deque #cnt a) -> Maybe (Idx #cnt)
+find_idx f p => unsafe_find_idx (back p) @p.height f p.data
+
+unsafe_find_idx :: { Load p } =>
+ Idx #cnt -> W32 -> (a -> Bool) -> Pointer p (Array #cnt a) ->
+ Maybe (Idx #cnt)
+unsafe_find_idx b j f p => do
+ i = new (0 :: W32)
+ while ((@i < j) && (not (f @p[wrap_add b @i]))) (inc i)
+ branch
+ @i == j -> Nothing
+ | Just (unsafe_to_idx @i)
+
+map :: (a -> b) -> Ptr (Deque #cnt a) -> Deque #cnt b
+map f p => do
+ q = unsafe_alloca
+ foreach_idx (A.map_idx f p.data q.data) p
+ q.height <- @p.height
+ q.back <- @p.back
+ load q
+
+foreach :: { Load p } =>
+ (Pointer p a -> ()) -> Pointer p (Deque #cnt a) -> ()
+foreach f p => foreach_idx (A.apply_at_idx f p.data) p
+
+foreach_idx :: { Load p } =>
+ (Idx #cnt -> ()) -> Pointer p (Deque #cnt a) -> ()
+foreach_idx f p => unsafe_foreach_idx (back p) @p.height f
+
+unsafe_foreach_idx :: Idx #cnt -> W32 -> (Idx #cnt -> ()) -> ()
+unsafe_foreach_idx b h f => times h (\i -> f (wrap_add b i))
+
+deque :: #cnt -> Deque #cnt a
+deque _ => do
+ p = unsafe_alloca
+ p.back <- 0
+ empty p
+ load p
+
+empty :: Ptr (Deque #cnt a) -> ()
+empty p => p.height <- 0
+
+push_front :: a -> Ptr (Deque #cnt a) -> Bool
+push_front a p => branch
+ is_full p -> False
+ | do
+ p.data[front p] <- a
+ inc p.height
+ True
+
+pop_front :: Ptr (Deque #cnt a) -> Maybe a
+pop_front p => branch
+ is_empty p -> Nothing
+ | do
+ dec p.height
+ Just @p.data[front p]
+
+push_back :: a -> Ptr (Deque #cnt a) -> Bool
+push_back a p => branch
+ is_full p -> False
+ | do
+ p.data[@p.back] <- a
+ p.back <- wrap_dec @p.back
+ inc p.height
+ True
+
+pop_back :: Ptr (Deque #cnt a) -> Maybe a
+pop_back p => branch
+ del_back p -> Just @p.data[@p.back]
+ | Nothing
+
+del_back :: Ptr (Deque #cnt a) -> Bool
+del_back p => branch
+ is_empty p -> False
+ | do
+ p.back <- wrap_add @p.back 1
+ dec p.height
+ True
+
+is_empty :: { Load p } => Pointer p (Deque #cnt a) -> Bool
+is_empty p => @p.height == 0
+
+is_full :: { Load p } => Pointer p (Deque #cnt a) -> Bool
+is_full p => @p.height == count p.data
+
+front :: { Load p } => Pointer p (Deque #cnt a) -> Idx #cnt
+front p => wrap_add (back p) @p.height
+
+back :: { Load p } => Pointer p (Deque #cnt a) -> Idx #cnt
+back p => wrap_add @p.back 1
+
+wrap_op :: (W32 -> W32) -> Idx #cnt -> Idx #cnt
+wrap_op f a => unsafe_to_idx ((f (from_idx a)) % (count_idx a))
+
+wrap_add :: Idx #cnt -> W32 -> Idx #cnt
+wrap_add a b => wrap_op (add b) a
+
+wrap_dec :: Idx #cnt -> Idx #cnt
+wrap_dec a => wrap_add a (count_idx a - 1)
+
+put :: { Load p } =>
+ (a -> ()) -> Pointer p (Deque #cnt a) -> ()
+put f p => putBrackets (foreach (putElem f) p)
+
+fold :: { Load p } => (b -> a -> b) -> b -> Pointer p (Deque #cnt a) -> b
+fold f b deq => do
+ pb = new b
+ foreach (fold_ptr f pb) deq
+ @pb
diff --git a/lib/Data/Queue.pec b/lib/Data/Queue.pec
new file mode 100644
--- /dev/null
+++ b/lib/Data/Queue.pec
@@ -0,0 +1,81 @@
+module Data.Queue
+
+exports
+ Queue
+ any
+ del
+ empty
+ filter
+ find
+ find_idx
+ fold
+ foreach
+ foreach_idx
+ is_empty
+ is_full
+ map
+ pop
+ push
+ put
+ queue
+
+imports
+ Prelude
+ Data.Deque as D
+
+where
+
+type Queue cnt a = | Queue (D.Deque #cnt a)
+
+queue :: #cnt -> Queue #cnt a
+queue cnt => Queue (D.deque cnt)
+
+push :: a -> Ptr (Queue #cnt a) -> Bool
+push a p => D.push_front a (queue_unwrapptr p)
+
+pop :: Ptr (Queue #cnt a) -> Maybe a
+pop p => D.pop_back (queue_unwrapptr p)
+
+del :: Ptr (Queue #cnt a) -> Bool
+del p => D.del_back (queue_unwrapptr p)
+
+empty :: Ptr (Queue #cnt a) -> ()
+empty p => D.empty (queue_unwrapptr p)
+
+is_empty :: { Load p } => Pointer p (Queue #cnt a) -> Bool
+is_empty p => D.is_empty (queue_unwrapptr p)
+
+is_full :: { Load p } => Pointer p (Queue #cnt a) -> Bool
+is_full p => D.is_full (queue_unwrapptr p)
+
+put :: { Load p } =>
+ (a -> ()) -> Pointer p (Queue #cnt a) -> ()
+put f p => D.put f (queue_unwrapptr p)
+
+map :: (a -> b) -> Ptr (Queue #cnt a) -> Queue #cnt b
+map f p => Queue (D.map f (queue_unwrapptr p))
+
+foreach :: { Load p } =>
+ (Pointer p a -> ()) -> Pointer p (Queue #cnt a) -> ()
+foreach f p => D.foreach f (queue_unwrapptr p)
+
+foreach_idx :: { Load p } =>
+ (Idx #cnt -> ()) -> Pointer p (Queue #cnt a) -> ()
+foreach_idx f p => D.foreach_idx f (queue_unwrapptr p)
+
+fold :: { Load p } => (b -> a -> b) -> b -> Pointer p (Queue #cnt a) -> b
+fold f b p => D.fold f b (queue_unwrapptr p)
+
+any :: { Load p } => (a -> Bool) -> Pointer p (Queue #cnt a) -> Bool
+any f p => D.any f (queue_unwrapptr p)
+
+find :: { Load p } =>
+ (a -> Bool) -> Pointer p (Queue #cnt a) -> Maybe (Pointer p a)
+find f p => D.find f (queue_unwrapptr p)
+
+find_idx :: { Load p } =>
+ (a -> Bool) -> Pointer p (Queue #cnt a) -> Maybe (Idx #cnt)
+find_idx f p => D.find_idx f (queue_unwrapptr p)
+
+filter :: (a -> Bool) -> Ptr (Queue #cnt a) -> ()
+filter f p => D.filter f (queue_unwrapptr p)
diff --git a/lib/Data/Stack.pec b/lib/Data/Stack.pec
new file mode 100644
--- /dev/null
+++ b/lib/Data/Stack.pec
@@ -0,0 +1,119 @@
+module Data.Stack
+
+// explicit export list
+
+exports
+ Stack
+ any
+ empty
+ filter
+ find
+ find_idx
+ fold
+ foreach
+ foreach_idx
+ is_empty
+ is_full
+ map
+ pop
+ push
+ put
+ stack
+
+imports
+ Prelude
+ Data.Array as A
+
+where
+
+// BAL: some Ptr's can be changed to Load Pointers
+
+type Stack cnt a =
+ { height :: W32
+ , data :: Array #cnt a
+ }
+// stacks are polymorphic in their size and what they contain
+
+filter :: (a -> Bool) -> Ptr (Stack #cnt a) -> ()
+filter f p => do
+ h = @p.height
+ empty p
+ A.unsafe_foreach_idx h (filter_elem f p)
+
+filter_elem :: (a -> Bool) -> Ptr (Stack #cnt a) -> Idx #cnt -> ()
+filter_elem f p i => do
+ a = @p.data[i]
+ when (f a) (assert (push a p))
+
+find :: (a -> Bool) -> Ptr (Stack #cnt a) -> Maybe (Ptr a)
+find f p => case new (find_idx f p) of
+ Nothing -> Nothing
+ Just i -> Just p.data[@i]
+
+find_idx :: (a -> Bool) -> Ptr (Stack #cnt a) -> Maybe (Idx #cnt)
+find_idx f p => A.unsafe_find_idx @p.height f p.data
+
+any :: (a -> Bool) -> Ptr (Stack #cnt a) -> Bool
+any f p => case new (find_idx f p) of
+ Nothing -> False
+ Just _ -> True
+
+fold :: { Load p } => (b -> a -> b) -> b -> Pointer p (Stack #cnt a) -> b
+fold f b stck => do
+ pb = new b
+ foreach (fold_ptr f pb) stck
+ @pb
+
+map :: (a -> b) -> Ptr (Stack #cnt a) -> Stack #cnt b
+map f p => do
+ q = unsafe_alloca
+ foreach_idx (A.map_idx f p.data q.data) p
+ q.height <- @p.height
+ load q
+
+foreach_idx :: { Load p } =>
+ (Idx #cnt -> ()) -> Pointer p (Stack #cnt a) -> ()
+foreach_idx f p => A.unsafe_foreach_idx @p.height f
+
+foreach :: { Load p } =>
+ (Pointer p a -> ()) -> Pointer p (Stack #cnt a) -> ()
+foreach f p => foreach_idx (A.apply_at_idx f p.data) p
+
+stack :: #cnt -> Stack #cnt a
+stack _ => do
+ p = unsafe_alloca
+ empty p
+ load p
+
+push :: a -> Ptr (Stack #cnt a) -> Bool
+push a p => branch
+ is_full p -> False
+ | do
+ p.data[unsafe_to_idx @p.height] <- a
+ inc p.height
+ True
+
+pop :: Ptr (Stack #cnt a) -> Maybe a
+pop p => branch
+ del p -> Just @p.data[unsafe_to_idx @p.height]
+ | Nothing
+
+del :: Ptr (Stack #cnt a) -> Bool
+del p => branch
+ is_empty p -> False
+ | do
+ dec p.height
+ True
+
+is_empty :: { Load p } => Pointer p (Stack #cnt a) -> Bool
+is_empty p => @p.height == 0
+
+is_full :: { Load p } => Pointer p (Stack #cnt a) -> Bool
+is_full p => @p.height > unsafe_cast (A.max_idx p.data)
+
+empty :: Ptr (Stack #cnt a) -> ()
+empty p => p.height <- 0
+
+put :: { Load p } =>
+ (a -> ()) -> Pointer p (Stack #cnt a) -> ()
+put f p => putBrackets (foreach (putElem f) p)
diff --git a/lib/Data/StrBuf.pec b/lib/Data/StrBuf.pec
new file mode 100644
--- /dev/null
+++ b/lib/Data/StrBuf.pec
@@ -0,0 +1,45 @@
+module Data.StrBuf
+
+imports
+ Prelude
+ Data.Array as A
+
+where
+
+type StrBuf cnt = | StrBuf (Array #cnt Char)
+
+extern "strcmp" c_strcmp :: { Load p, Load q } =>
+ Pointer p Char -> Pointer q Char -> I32
+extern "strlen" c_strlen :: { Load p } => Pointer p Char -> W32
+extern "strncpy" c_strncpy :: { Store p, Load q } =>
+ Pointer p Char -> Pointer q Char -> W32 -> ()
+
+from_strbuf :: Pointer p (StrBuf #cnt) -> Pointer p Char
+from_strbuf => unsafe_cast
+
+strcmp :: { Load p, Load q } => Pointer p (StrBuf #a) -> Pointer q (StrBuf #b) -> Ordering
+strcmp a b => to_ordering (c_strcmp (from_strbuf a) (from_strbuf b))
+
+strlen :: { Load p } => Pointer p (StrBuf #cnt) -> W32
+strlen a => c_strlen (from_strbuf a)
+
+to_strbuf :: IString -> Ptr (StrBuf #cnt) -> Bool
+to_strbuf a => cstrcpy (iString_unwrapptr a)
+
+strcpy :: { Load p } => Pointer p (StrBuf #a) -> Ptr (StrBuf #b) -> Bool
+strcpy a => cstrcpy (from_strbuf a)
+
+cstrcpy :: { Load p } => Pointer p Char -> Ptr (StrBuf #cnt) -> Bool
+cstrcpy a b => do
+ p => strBuf_unwrapptr b
+ c_strncpy (from_strbuf b) a (count p)
+ q => p[idx_max]
+ r = @q == '\0'
+ q <- '\0'
+ r
+
+strbuf :: #cnt -> StrBuf #cnt
+strbuf cnt => StrBuf (A.array cnt '\0')
+
+put :: { Load p } => Pointer p (StrBuf #cnt) -> ()
+put x => putS (unsafe_cast (from_strbuf x))
diff --git a/lib/Prelude.pec b/lib/Prelude.pec
--- a/lib/Prelude.pec
+++ b/lib/Prelude.pec
@@ -1,55 +1,240 @@
module Prelude
-exports all
-
where
-type W8 = W #256 //singleton "Count" type. In this case, used to specify a word that holds 256 values.
-type W16 = W #65536
-type I32 = I #4294967296 // 32 bit int
+type W8 = W #8 //An unsigned 8-bit word.
+type W16 = W #16
+type W32 = W #32
+type W64 = W #64
+type I8 = I #8 // a signed 8-bit int
+type I16 = I #16
+type I32 = I #32
+type I64 = I #64
type Bool = | False | True
// enum type
// the "|" is used to specify "or"
+instance Eq Bool // eq and ne can be derived for enums
+
type Maybe a = | Nothing | Just a // polymorphic variant
// order doesn't matter
// type Maybe a = | Just a | Nothing would be compiled exactly the same way
+is_nothing :: { Load p } => Pointer p (Maybe a) -> Bool
+is_nothing x => case x of
+ Nothing -> True
+ _ -> False
+
type Either a b = | Left a | Right b // polymorphic variant
type Ordering = | LT | EQ | GT // another enum
-extern putchar :: Char -> ()
-// external C call
-// name on the left, type on the right
+instance Eq Ordering
-extern puts :: Ptr Char -> ()
-extern exit :: I32 -> ()
+// externally defined names. name on the left, type on the right
+// external C calls
+new :: a -> Ptr a
+new a => do
+ p = unsafe_alloca
+ p <- a
+ p
+
+extern unsafe_alloca :: Ptr a
+
+unsafe_alloca_array :: #cnt -> Ptr (Array #cnt a)
+unsafe_alloca_array _ => unsafe_alloca
+
+extern store :: { Store p } => Pointer p a -> a -> ()
+extern load :: { Load p } => Pointer p a -> a
+extern idx :: Pointer p (Array #cnt a) -> Idx #cnt -> Pointer p a
+extern then :: () -> a -> a
+
+extern exit :: I32 -> a
+
+// language primitives
+extern add :: { Arith a } => a -> a -> a
+extern sub :: { Arith a } => a -> a -> a
+extern mul :: { Arith a } => a -> a -> a
+extern div :: { Arith a } => a -> a -> a
+extern rem :: { Arith a } => a -> a -> a
+extern gt :: { Ord a } => a -> a -> Bool
+extern gte :: { Ord a } => a -> a -> Bool
+extern lt :: { Ord a } => a -> a -> Bool
+extern lte :: { Ord a } => a -> a -> Bool
+extern eq :: { Eq a } => a -> a -> Bool
+extern ne :: { Eq a } => a -> a -> Bool
+extern shl :: W #a -> W #a -> W #a
+extern shr :: W #a -> W #a -> W #a
+extern band :: W #a -> W #a -> W #a
+extern bor :: W #a -> W #a -> W #a
+extern bxor :: W #a -> W #a -> W #a
+extern bnot :: W #a -> W #a -> W #a
+// BAL: support ashr?
+
+extern if :: Bool -> a -> a -> a
+extern when :: Bool -> () -> ()
+extern while :: Bool -> () -> ()
+
+eq_eq => eq
+bang_eq => ne
+gt_eq => gte
+lt_eq => lte
+add_eq p x => p <- @p + x
+sub_eq p x => p <- @p - x
+mul_eq p x => p <- @p * x
+div_eq p x => p <- @p / x
+
+and :: Bool -> Bool -> Bool
+and a b => if a b False
+band_band => and
+
+or :: Bool -> Bool -> Bool
+or a b => if a True b
+bor_bor => or
+
+lt_lt => shl
+gt_gt => shr
+
+extern abs :: { Arith a } => a -> a
+extern acos :: { Floating a } => a -> a
+extern asin :: { Floating a } => a -> a
+extern atan :: { Floating a } => a -> a
+extern atan2 :: { Floating a } => a -> a
+extern ceil :: { Floating a } => a -> a
+extern cos :: { Floating a } => a -> a
+extern cosh :: { Floating a } => a -> a
+extern exp :: { Floating a } => a -> a
+extern floor :: { Floating a } => a -> a
+extern log :: { Floating a } => a -> a
+extern log10 :: { Floating a } => a -> a
+extern pow :: { Floating a } => a -> a -> a
+extern sin :: { Floating a } => a -> a
+extern sinh :: { Floating a } => a -> a
+extern sqrt :: { Floating a } => a -> a
+extern tan :: { Floating a } => a -> a
+extern tanh :: { Floating a } => a -> a
+
+sqrtw :: W #cnt -> W #cnt
+sqrtw x => unsafe_cast (floor (sqrt ((unsafe_cast x) :: Double)))
+
+extern "printf" unsafe_printf :: { Load p } => Pointer p Char -> a -> ()
+
+putW :: W #cnt -> ()
+putW => unsafe_putS "%u"
+
+putI :: I #cnt -> ()
+putI => unsafe_putS "%i"
+
+putF :: Float -> ()
+putF => unsafe_putS "%f"
+
+putD :: Double -> ()
+putD => unsafe_putS "%f"
+
+inc :: { Arith a } => Ptr a -> ()
+inc x => x <- @x + 1
+
+dec :: { Arith a } => Ptr a -> ()
+dec x => x <- @x - 1
+
+for :: a -> (a -> Bool) -> (a -> a) -> (a -> ()) -> ()
+for a f g h => do
+ p = new a
+ while (f @p)
+ (do
+ h @p
+ p <- g @p
+ )
+
+times :: { Arith a, Ord a } => a -> (a -> ()) -> ()
+times n f => for 0 (\i -> i < n) succ f
+
+succ :: { Arith a } => a -> a
+succ a => a + 1
+
+flip :: (a -> b -> c) -> b -> a -> c
+flip f b a => f a b
+
+chr :: W8 -> Char
+chr => unsafe_cast
+
+ord :: Char -> W8
+ord => unsafe_cast
+
+from_idx :: Idx #cnt -> W32
+from_idx => unsafe_cast
+
+unsafe_to_idx :: W32 -> Idx #cnt
+unsafe_to_idx => unsafe_cast
+
to_ordering :: I32 -> Ordering
-to_ordering x = branch of
- | x < 0 -> LT
- | x > 0 -> GT
- | -> EQ
+to_ordering x = branch
+ x < 0 -> LT
+ x > 0 -> GT
+ | EQ
putCh :: Char -> ()
-putCh c = putchar c
+putCh => unsafe_putS "%c"
+putElem :: { Load p } => (a -> ()) -> Pointer p a -> ()
+putElem f p => do
+ f @p
+ putCh ' '
+
+putBrackets :: () -> ()
+putBrackets f => do
+ putCh '['
+ putCh ' '
+ f
+ putCh ']'
+
assert :: Bool -> ()
-assert x = when (not x)
- (do
- putLn "assertion failed"
- exit -1
- )
-// "when" is not a primitive, it is a library function, see "when_" below
+assert x = when (not x) (error "assertion failed")
not :: Bool -> Bool
-not x = if x False True
+not x => if x False True
+error :: IString -> a
+error x => do
+ putLn x
+ exit -1
+ unsafe_alpha
+
+undefined :: a
+undefined => error "undefined"
+
+extern unsafe_alpha :: a
+
+putS :: IString -> ()
+putS x => unsafe_putS "%s" x
+
+unsafe_putS :: IString -> a -> ()
+unsafe_putS x => unsafe_printf (iString_unwrapptr x)
+
putLn :: IString -> ()
-putLn x = puts (from_istring x)
+putLn x => do
+ putS x
+ putS "\n"
+// different pointer types
+type Ptr a = Pointer LoadStoreP a
+type RPtr a = Pointer LoadP a
+type WPtr a = Pointer StoreP a
+
+type LoadP
+type StoreP
+type LoadStoreP
+
+instance Load LoadP
+instance Store StoreP
+instance Load LoadStoreP
+instance Store LoadStoreP
+
+iString_unwrapptr :: IString -> RPtr Char
+iString_unwrapptr => unsafe_cast
+
is_upper :: Char -> Bool
is_upper c = (c >= 'A') && (c <= 'Z') // operators don't have precedence, parens are required
@@ -60,228 +245,54 @@
is_digit c = (c >= '0') && (c <= '9')
to_lower :: Char -> Char
-to_lower c = branch of
- | is_upper c -> chr (ord c + 32)
- | -> c
+to_lower c = branch
+ is_upper c -> chr (ord c + 32)
+ | c
to_upper :: Char -> Char
-to_upper c = branch of
- | is_lower c -> chr (ord c - 32)
- | -> c
+to_upper c = branch
+ is_lower c -> chr (ord c - 32)
+ | c
-// inline Haskell "library" DSL code
+otherwise :: Bool
+otherwise => True
->import Pec.Base
->import Data.List
->
->type CntW8 = Cnt256
->type W8 = W CntW8
->type Char_ = Char
->type Ptr_ a = Ptr a
->type IString_ = IString
->type W32_ = W32
->type Float_ = Float
->type Double_ = Double
->
->class Typed a => ARITH a where
-> add :: Term a -> Term a -> Term a
-> sub :: Term a -> Term a -> Term a
-> mul :: Term a -> Term a -> Term a
-> adiv :: Term a -> Term a -> Term a
-> arem :: Term a -> Term a -> Term a
->
->class Typed a => BITS a where
-> shl :: Term a -> Term a -> Term a
-> shr :: Typed a => Term a -> Term a -> Term a
-> band :: Term a -> Term a -> Term a
-> bor :: Term a -> Term a -> Term a
-> xor :: Term a -> Term a -> Term a
-> -- support ashr?
->
->class Typed a => ORD a where
-> gt :: Term a -> Term a -> Term Bool_
-> ge :: Term a -> Term a -> Term Bool_
-> lt :: Term a -> Term a -> Term Bool_
-> le :: Term a -> Term a -> Term Bool_
->
->class Typed a => EQ a where
-> eq :: Term a -> Term a -> Term Bool_
-> eq = prim2 "icmp eq"
-> ne :: Term a -> Term a -> Term Bool_
-> ne = prim2 "icmp ne"
->
->class (Typed a, Show a) => FRAC a where
-> frac :: a -> Term a
-> frac = val . show
->
-// operators must be defined using the DSL
-// The '$' is tacked on by the compiler in order to avoid name clashes.
->(@$) :: Typed a => Term (Ptr a) -> Term a
->(@$) = load
->
->(>$) :: ORD a => Term a -> Term a -> Term Bool_
->(>$) = gt
->
->(>=$) :: ORD a => Term a -> Term a -> Term Bool_
->(>=$) = ge
->
->(<$) :: ORD a => Term a -> Term a -> Term Bool_
->(<$) = lt
->
->(<=$) :: ORD a => Term a -> Term a -> Term Bool_
->(<=$) = le
->
->(+$) :: ARITH a => Term a -> Term a -> Term a
->(+$) = add
->
->(-$) :: ARITH a => Term a -> Term a -> Term a
->(-$) = sub
->
->(*$) :: ARITH a => Term a -> Term a -> Term a
->(*$) = mul
->
->(/$) :: ARITH a => Term a -> Term a -> Term a
->(/$) = adiv
->
->(%$) :: ARITH a => Term a -> Term a -> Term a
->(%$) = arem
->
->(==$) :: EQ a => Term a -> Term a -> Term Bool_
->(==$) = eq
->
->(!=$) :: EQ a => Term a -> Term a -> Term Bool_
->(!=$) = ne
->
->(<<$) :: BITS a => Term a -> Term a -> Term a
->(<<$) = shl
->
->(>>$) :: BITS a => Term a -> Term a -> Term a
->(>>$) = shr
->
->(&$) :: BITS a => Term a -> Term a -> Term a
->(&$) = band
->
->(|$) :: BITS a => Term a -> Term a -> Term a
->(|$) = bor
->
->(^$) :: BITS a => Term a -> Term a -> Term a
->(^$) = xor
->
->(&&$) :: Term Bool_ -> Term Bool_ -> Term Bool_
->(&&$) x y = Lift $ do
-> a <- eval x
-> b <- eval y
-> return $ switch a
-> [(false_tag, false_alt (\ _ -> false_))
-> ,(defaulttag, \ _ -> b)]
->
->(||$) :: Term Bool_ -> Term Bool_ -> Term Bool_
->(||$) x y = Lift $ do
-> a <- eval x
-> b <- eval y
-> return $ switch a
-> [(true_tag, true_alt (\ _ -> true_))
-> ,(defaulttag, \ _ -> b)]
->
-// ad-hoc polymorphism, using Haskell classes
->instance Count cnt => EQ (I cnt)
->instance Count cnt => EQ (W cnt)
->instance EQ Char
->instance EQ IString
->instance (EQ a, EQ b) => EQ (a,b)
->instance INT Double where int = frac . fromInteger
->instance INT Float where int = frac . fromInteger
->instance FRAC Double
->instance FRAC Float
->
->instance Count cnt => BITS (W cnt) where
-> shl = prim2 "shl"
-> shr = prim2 "lshr"
-> band = prim2 "and"
-> bor = prim2 "or"
-> xor = prim2 "xor"
->
->instance Count cnt => ORD (W cnt) where
-> gt = prim2 "icmp ugt"
-> ge = prim2 "icmp uge"
-> lt = prim2 "icmp ult"
-> le = prim2 "icmp ule"
->
->instance ORD Char where
-> gt = prim2 "icmp ugt"
-> ge = prim2 "icmp uge"
-> lt = prim2 "icmp ult"
-> le = prim2 "icmp ule"
->
->instance Count cnt => ORD (I cnt) where
-> gt = prim2 "icmp sgt"
-> ge = prim2 "icmp sge"
-> lt = prim2 "icmp slt"
-> le = prim2 "icmp sle"
->
->instance ORD Double where
-> gt = prim2 "fcmp ogt"
-> ge = prim2 "fcmp oge"
-> lt = prim2 "fcmp olt"
-> le = prim2 "fcmp ole"
->
->instance ORD Float where
-> gt = prim2 "fcmp ogt"
-> ge = prim2 "fcmp oge"
-> lt = prim2 "fcmp olt"
-> le = prim2 "fcmp ole"
->
->instance Count cnt => ARITH (I cnt) where
-> add = prim2 "add"
-> sub = prim2 "sub"
-> mul = prim2 "mul"
-> adiv = prim2 "sdiv"
-> arem = prim2 "srem"
->
->instance Count cnt => ARITH (W cnt) where
-> add = prim2 "add"
-> sub = prim2 "sub"
-> mul = prim2 "mul"
-> adiv = prim2 "udiv"
-> arem = prim2 "urem"
->
->instance ARITH Double where
-> add = prim2 "fadd"
-> sub = prim2 "fsub"
-> mul = prim2 "fmul"
-> adiv = prim2 "fdiv"
-> arem = prim2 "frem"
->
->instance ARITH Float where
-> add = prim2 "fadd"
-> sub = prim2 "fsub"
-> mul = prim2 "fmul"
-> adiv = prim2 "fdiv"
-> arem = prim2 "frem"
->
->eq_unit = \_ _ -> true_
->ne_unit = \_ _ -> false_
->
->instance EQ () where
-> eq = eq_unit
-> ne = ne_unit
->
-// polymorphic function
-// note that the '_' is added to the end of pec names to avoid name clashes
->array_ :: (Count cnt, Typed cnt, Typed a) => Term (cnt -> a -> Array cnt a)
->array_ = lam2_ $ \(cnt :: Term cnt) x -> Lift $ do
-> a <- eval x
-> return $ array cnt $ genericReplicate (countof (unused :: cnt)) a
->
->ord_ :: Term (Char -> W8)
->ord_ = lam_ cast
->
->chr_ :: Term (W8 -> Char)
->chr_ = lam_ cast
->
->if_ :: Typed a => Term (Bool_ -> a -> a -> a)
->if_ = lam3_ $ \f g h ->
-> switch f [(true_tag, \_ -> g), (false_tag, \_ -> h)]
->
->when_ :: Term (Bool_ -> () -> ())
->when_ = lam2_ $ \a b -> app3 if_ a b unit
+min :: { Ord a } => a -> a -> a
+min a b => do
+ x = a
+ y = b
+ if (x < y) x y
+
+max :: { Ord a } => a -> a -> a
+max a b => do
+ x = a
+ y = b
+ if (x > y) x y
+
+max_idx :: Idx #cnt -> Idx #cnt
+max_idx _ => idx_max
+
+count_idx :: Idx #cnt -> W32
+count_idx x => from_idx (max_idx x) + 1
+
+id :: a -> a
+id x => x
+
+type Pair a b = { fst :: a, snd :: b }
+
+pair :: a -> b -> (a,b)
+pair a b => (a,b) // same as { fst = a, snd = b }
+
+fst :: Pointer p (a,b) -> Pointer p a
+fst (a,_) => a
+
+snd :: Pointer p (a,b) -> Pointer p b
+snd (_,b) => b
+
+ignore :: a -> b -> b
+ignore _ b => b
+
+extern void :: ()
+
+fold_ptr :: { Load p } => (b -> a -> b) -> Ptr b -> Pointer p a -> ()
+fold_ptr f pb pa => pb <- f @pb @pa
diff --git a/lib/Stack.pec b/lib/Stack.pec
deleted file mode 100644
--- a/lib/Stack.pec
+++ /dev/null
@@ -1,50 +0,0 @@
-module Stack
-
-exports (Stack, stack, push, pop, is_empty, is_full)
-// explicit export list
-
-where
-
-import Prelude
-
-type Stck #cnt a = { height :: W32, data :: Array cnt a }
-// stacks are polymorphic in their size and what they contain
-
-type Stack #cnt a = Stck cnt a
-
->type Stack cnt a = Stack_ cnt a
->
->stack_ :: (Count cnt, Typed cnt, Typed a) => Term (cnt -> Stack cnt a)
->stack_ = lam_ $ \_ -> lift $ do
-> p <- eval $ alloca unused
-> eval_ $ store (height_get p) (int 0)
-> return $ load p
->
->push_ :: (Count cnt, Typed cnt, Typed a) =>
-> Term (a -> Ptr (Stack cnt a) -> Bool_)
->push_ = lam2_ $ \a (p :: Term (Ptr (Stack cnt a))) ->
-> app3 if_ (app is_full_ p)
-> false_
-> (lift (do i <- eval $ load (height_get p)
-> evalv $ store (idx (data_get p) (cast i)) a
-> evalv $ store (height_get p) (add i (int 1))
-> return true_
-> ))
->
->pop_ :: (Count cnt, Typed cnt, Typed a) =>
-> Term (Ptr (Stack cnt a) -> Maybe_ a)
->pop_ = lam_ $ \p -> app3 if_ (app is_empty_ p)
-> nothing_
-> (lift (do i <- eval $ sub (load (height_get p)) (int 1)
-> evalv $ store (height_get p) i
-> return $ app just_ (load (idx (data_get p) (cast i)))
-> ))
->
->is_empty_ :: (Count cnt, Typed cnt, Typed a) =>
-> Term (Ptr (Stack cnt a) -> Bool_)
->is_empty_ = lam_ $ \p -> eq (load (height_get p)) (int 0)
->
->is_full_ :: (Count cnt, Typed cnt, Typed a) =>
-> Term (Ptr (Stack cnt a) -> Bool_)
->is_full_ = lam_ $ \(p :: Term (Ptr (Stack cnt a))) ->
-> eq (load (height_get p)) (int $ countof (unused :: cnt))
diff --git a/lib/StrBuf.pec b/lib/StrBuf.pec
deleted file mode 100644
--- a/lib/StrBuf.pec
+++ /dev/null
@@ -1,48 +0,0 @@
-module StrBuf exports all
-
-where
-
-import Prelude
-
-type StrBuf #cnt = | StrBuf (Array (SuccCnt cnt) Char)
-
-extern "strcmp" c_strcmp :: Ptr Char -> Ptr Char -> I32
-extern "strlen" c_strlen :: Ptr Char -> W32
-extern "strncpy" c_strncpy :: Ptr Char -> Ptr Char -> I32 -> Ptr Char
-// a different name can be used for the C call if necessary
-
->type StrBuf a = StrBuf_ a
->
->strbuf_ :: (Count cnt, Typed cnt) => Term (cnt -> StrBuf cnt)
->strbuf_ = lam_ $ \(a :: Term cnt) ->
-> cast (app2 array_ (unused :: Term (SuccCnt cnt)) (char '\0'))
->
->from_strbuf_ :: Count cnt => Term (Ptr (StrBuf cnt) -> Ptr Char)
->from_strbuf_ = lam_ bitcast
->
->put_ :: Count cnt => Term (Ptr (StrBuf cnt) -> ())
->put_ = lam_ $ \p -> app puts_ (app from_strbuf_ p)
->
->strlen_ :: Count cnt => Term (Ptr (StrBuf cnt) -> W32)
->strlen_ = lam_ $ \x -> app c_strlen_ (app from_strbuf_ x)
->
->strcmp_ :: (Count a, Count b) =>
-> Term (Ptr (StrBuf a) -> Ptr (StrBuf b) -> Ordering_)
->strcmp_ = lam2_ $ \x y ->
-> app to_ordering_ (app2 c_strcmp_ (app from_strbuf_ x) (app from_strbuf_ y))
->
->to_strbuf_ :: Count cnt => Term (IString -> Ptr (StrBuf cnt) -> Bool_)
->to_strbuf_ = lam2_ $ \x y -> app2 strncpy (app from_istring_ x) y
->
->strcpy_ :: (Count a, Count b) =>
-> Term (Ptr (StrBuf a) -> Ptr (StrBuf b) -> Bool_)
->strcpy_ = lam2_ $ \x y -> app2 strncpy (app from_strbuf_ x) y
->
->strncpy :: Count cnt => Term (Ptr Char -> Ptr (StrBuf cnt) -> Bool_)
->strncpy = lam2_ $ \x (y :: Term (Ptr (StrBuf cnt))) -> Lift $ do
-> let n = countof (unused :: cnt)
-> evalv $ app3 c_strncpy_ (app from_strbuf_ y) x (int $ succ n)
-> c <- eval $ idx (app unwrap_ptr_ y) (int n)
-> return $ app3 if_ (load c `eq` char '\0')
-> true_
-> (lift (eval (store c (char '\0')) >> return false_))
diff --git a/pec.cabal b/pec.cabal
--- a/pec.cabal
+++ b/pec.cabal
@@ -1,46 +1,48 @@
-Name: pec
-
-Version: 0.1.1
-
-Synopsis: pec embedded compiler
-
-Description: The intent of pec is to provide a drop-in replacement for C, but with modern language features. Pec is a procedural language with a functional/declarative feel. Programming in pec is very similar to monadic programming in Haskell. The primary use case for pec is to provide a productive environment for writing safe, efficient, embedded applications.
-
-License: BSD3
-
-License-file: LICENSE
-
-Author: Brett Letner
-
-Maintainer: Brett Letner
-
-Copyright: Brett letner 2011
-
-Category: Language
-
-Build-type: Simple
-
-Extra-source-files: Pec.cf
-
-data-files: Makefile, FAQ, Pec/Makefile, DESIGN, lib/Stack.pec, lib/StrBuf.pec, lib/Prelude.pec, test_cases/Makefile, test_cases/TestStack.pec, test_cases/TestLoad.pec, test_cases/TestPrims.pec, test_cases/TestTuple.pec, test_cases/TestStrBuf.pec, test_cases/TestVariant.pec, test_cases/TestArray.pec, pec.cabal, THANKS, README, TODO, LICENSE, Language/Pec/Doc.html
-
-Cabal-version: >= 1.6
-
-source-repository head
- type: git
- location: git://github.com/stevezhee/pec.git
-
-Library
- Exposed-modules: Pec.Base
- Build-depends: base
--- GHC-Options: -fhpc
-
-Executable pec
- Main-is: Main.hs
-
- Build-depends: base >= 4 && < 5, derive, array, filepath, cmdargs, mtl, process, directory, Cabal
-
- Other-modules: Language.Pec.Lex, Language.Pec.Layout, Language.Pec.ErrM, Language.Pec.Abs, Language.Pec.Par, Language.Pec.Print
-
--- Build-tools: happy, alex
- -- GHC-Options: -fhpc
+Name: pec
+
+Version: 0.2.0
+
+Synopsis: pec embedded compiler
+
+Description: The intent of pec is to provide a drop-in replacement for C, but with modern language features. Pec is a procedural language with a functional/declarative feel. Programming in pec is very similar to monadic programming in Haskell. The primary use case for pec is to provide a productive environment for writing safe, efficient, embedded applications.
+
+License: BSD3
+
+License-file: LICENSE
+
+Author: Brett Letner
+
+Maintainer: Brett Letner
+
+Copyright: Brett Letner 2011-2012
+
+Category: Language
+
+Build-type: Simple
+
+data-files: Makefile, FAQ, DESIGN, lib/Data/Array.pec, lib/Data/Stack.pec, lib/Data/Deque.pec, lib/Data/Queue.pec, lib/Data/StrBuf.pec, lib/Prelude.pec, test_cases/TestStack.pec, test_cases/TestLoad.pec, test_cases/TestPrims.pec, test_cases/TestTuple.pec, test_cases/TestStrBuf.pec, test_cases/TestVariant.pec, test_cases/TestArray.pec, pec.cabal, THANKS, README, TODO, CHANGES, Pec.grm, Pir.grm, Pds.grm, C.grm, LLVM.grm, MkPec.hs
+
+Cabal-version: >= 1.8
+
+source-repository head
+ type: git
+ location: git://github.com/stevezhee/pec.git
+
+Library
+ Exposed-modules: Pec.Base, Pec.C, Pec.LLVM, Pec.PUtil, Pec.HUtil, Pec.IUtil, Pec.Desugar, Language.Pec.Abs, Language.Pec.Par, Language.Pir.Abs, Language.C.Abs, Language.LLVM.Abs, Language.Pds.Abs
+ Build-depends: base < 5, mtl, grm, Cabal, uniplate, derive, wl-pprint, syb, deepseq, array, containers, shake, cmdargs
+
+Executable pecgen
+ Main-is: PecGen.hs
+ Build-depends: pec, base < 5, derive, wl-pprint, filepath, cmdargs, grm, Cabal, syb, deepseq, uniplate, mtl, directory, shake
+ Hs-Source-Dirs: src, .
+
+Executable pec
+ Main-is: Pec.hs
+ Build-depends: pec, base < 5, old-time, process, filepath, directory, cmdargs, grm, Cabal, wl-pprint, syb, deepseq, uniplate, mtl, shake
+ Hs-Source-Dirs: src, .
+
+Executable pecgencnt
+ Main-is: PecGenCnt.hs
+ Build-depends: pec, base < 5, derive, cmdargs, grm, Cabal, wl-pprint, syb, deepseq, uniplate, mtl, filepath, shake
+ Hs-Source-Dirs: src, .
diff --git a/src/Pec.hs b/src/Pec.hs
new file mode 100644
--- /dev/null
+++ b/src/Pec.hs
@@ -0,0 +1,168 @@
+{-# OPTIONS -Wall -fno-warn-incomplete-patterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- The pec embedded compiler
+-- Copyright 2011-2012, Brett Letner
+
+module Main(main) where
+
+import Control.Monad
+import Data.List
+import Development.Shake hiding (getDirectoryContents)
+import Development.Shake.FilePath
+import Distribution.Text
+import Grm.Prims
+import Paths_pec
+import Pec.PUtil
+import System.Console.CmdArgs
+import System.Directory hiding (readable)
+
+data Args = Args
+ { targets :: [String]
+ , idir :: [FilePath]
+ , lib :: [String]
+ , ldir :: [FilePath]
+ , march :: Arch
+ , readable :: Bool
+ } deriving (Show, Data, Typeable)
+
+argsDesc :: Args
+argsDesc = Args
+ { targets = def &= args
+ , idir = def &= typDir &= help "import directory"
+ , lib = def &= help "library"
+ , ldir = def &= typDir &= name "L" &= help "library directory"
+ , march = def &= help "arch to build (C or LLVM)"
+ , readable = def &= help "generate human readable C (experimental)"
+ } &= summary summry &= program prog
+
+summry :: String
+summry = prog ++ " v" ++ display version ++ ", " ++ copyright
+
+prog :: String
+prog = "pec"
+
+buildDir :: String
+buildDir = ".build"
+
+mkTarget :: String -> String
+mkTarget t =
+ if takeExtension t == ".pec" then replaceExtension t "exe" else t
+
+getExeFiles :: IO [FilePath]
+getExeFiles = liftM (filter isExeFile) (getDirectoryContents ".")
+
+isExeFile :: FilePath -> Bool
+isExeFile = (==) ".exe" . takeExtension
+
+rmrf :: FilePath -> IO ()
+rmrf fn = do
+ r <- doesDirectoryExist fn
+ when r $ removeDirectoryRecursive fn
+
+main :: IO ()
+main = do
+ a <- cmdArgs argsDesc
+ libDir <- liftM takeDirectory $ getDataFileName "lib/Prelude.pec"
+ let idirs = ["."] ++ idir a ++ [libDir]
+
+ when ("clean" `elem` targets a) $ do
+ rmrf buildDir
+ getExeFiles >>= mapM_ removeFile
+
+ let ts = map mkTarget $ targets a \\ ["clean","run"]
+
+ let do_runghc outFn = do
+ let hsFn = dropExtension outFn ++ "_.hs"
+ need [hsFn]
+ system' "runghc"
+ [ "-i" ++ buildDir, hsFn
+ , "--march=" ++ show (march a)
+ , "--readable=" ++ show (readable a)]
+
+ -- shake shakeOptions{ shakeVerbosity = Diagnostic } $ do
+ shake shakeOptions $ do
+
+ want ts
+
+ "//*.exe" *> \outFn -> case march a of
+ C -> do
+ let depFn = buildPath $ replaceExtension outFn "dep"
+ need [depFn]
+ xs <- loadFileDeps depFn
+ let fns = [ replaceExtension x "o" | x <- xs ]
+ need fns
+ system' "gcc" $
+ ["-g", "-O2", "-Wall", "-Wextra", "-o", outFn] ++
+ ["-L" ++ l | l <- ldir a] ++ ["-l" ++ l | l <- lib a] ++ fns
+ LLVM -> do
+ let fn = buildPath $ replaceExtension outFn "s"
+ need [fn]
+ system' "gcc" [ "-O2", "-o", outFn, fn ]
+
+ "//*.s" *> \outFn -> do
+ let fn = replaceExtension outFn "opt"
+ need [fn]
+ system' "llc" [ "-o", outFn, fn ]
+
+ "//*.opt" *> \outFn -> do
+ let fn = replaceExtension outFn "bca"
+ need [fn]
+ system' "opt" [ "-o", outFn, "-std-compile-opts", "-std-link-opts", fn ]
+
+ "//*.bca" *> \outFn -> do
+ let depFn = replaceExtension outFn "dep"
+ need [depFn]
+ xs <- loadFileDeps depFn
+ let fns = [ replaceExtension x "bc" | x <- xs ]
+ need fns
+ system' "llvm-link" $ [ "-o", outFn ] ++ fns
+
+ "//*.o" *> \outFn -> do
+ let fn = replaceExtension outFn "c"
+ need [fn, replaceExtension outFn "h"]
+ system' "gcc" ["-g", "-o", outFn, "-c", fn ]
+
+ "//*.c" *> do_runghc
+ "//*.h" *> do_runghc
+ "//*.ll" *> do_runghc
+
+ "//*.bc" *> \outFn -> do
+ let fn = replaceExtension outFn "ll"
+ need [fn]
+ system' "llvm-as" ["-o", outFn, fn ]
+
+ "//*_.hs" *> \hsOut -> do
+ need [(init $ dropExtension hsOut) ++ ".dep"]
+
+ "//*.dep" *> \depOut -> do
+ let fn = dropDirectory1
+ (und_to_path (dropExtension depOut) ++ ".pec")
+ mFn <- liftIO $ findFile idirs fn
+ case mFn of
+ Nothing -> error $ "unknown file:" ++ fn
+ Just fn1 -> do
+ need [fn1] -- BAL: needed?
+ system' "pecgen" ["-d", buildDir, fn1]
+ (xs,ys) <- liftIO $ readFileDeps depOut
+ need [ buildPath $ x ++ ".dep" | x <- xs ]
+ need [ buildPath $ "Cnt" ++ show y ++ ".hs" | y <- ys ]
+
+ "//Cnt*.hs" *> \outFn -> system' "pecgencnt" [outFn]
+
+ when ("run" `elem` targets a) $ action $ do -- BAL: doesn't work under windows
+ pwd <- liftIO getCurrentDirectory
+ mapM_ (\fn -> system' (pwd fn) []) $ filter isExeFile ts
+
+loadFileDeps :: FilePath -> Action [String]
+loadFileDeps fn0 = loop [] [fn0]
+ where
+ loop xs [] = return xs
+ loop xs (y:ys)
+ | y `elem` xs = loop xs ys
+ | otherwise = do
+ (zs,_) <- liftIO $ readFileDeps y
+ loop (y : xs) ([ buildPath $ z ++ ".dep" | z <- zs ] ++ ys)
+
+buildPath :: FilePath -> FilePath
+buildPath x = buildDir x
diff --git a/src/PecGen.hs b/src/PecGen.hs
new file mode 100644
--- /dev/null
+++ b/src/PecGen.hs
@@ -0,0 +1,311 @@
+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- The pec embedded compiler
+-- Copyright 2011-2012, Brett Letner
+
+module Main (main) where
+
+import Data.Generics.Uniplate.Data
+import Data.List
+import Data.Maybe
+import Grm.Prims
+import Language.Haskell as H
+import Language.Pds.Abs as P
+import Pec.Desugar
+import Pec.HUtil
+import Pec.PUtil
+import System.Console.CmdArgs
+import System.Directory
+import System.FilePath
+
+data Args = Args
+ { files :: [FilePath]
+ , dir :: FilePath
+ } deriving (Show, Data, Typeable)
+
+argsDesc :: Args
+argsDesc = Args
+ { files = def &= args
+ , dir = def &= typDir &= help "output directory"
+ } &= summary (summarize prog) &= program prog
+
+prog :: String
+prog = "pecgen"
+
+main :: IO ()
+main = do
+ args <- cmdArgs argsDesc
+ let fns = files args
+ case fns of
+ [] -> putStrLn $ summarize prog
+ [fn] -> do
+ m0 <- parse_pec fn
+ let cnts = counts m0
+ m1 <- return $ desugar m0
+ let n = modid m1
+ createDirectoryIfMissing True $ dir args
+ writeFileDeps (joinPath [dir args, init n ++ ".dep"]) $
+ (map init $ imports m1, cnts)
+ m <- return $ hModule (dir args) cnts m1
+ writeFileBinary (joinPath [dir args, n ++ ".hs"]) $
+ prettyPrint m
+ _ -> error "expecting exactly one input file"
+
+hModule :: FilePath -> [Integer] -> P.Module -> H.Module
+hModule outdir cnts (P.Module a bs cs ds es fs) =
+ H.Module nl (ModuleName a)
+ hPragmas
+ Nothing
+ (Just $ map hExport bs)
+ (map hImport_ (["Pec.Base"] ++ map ((++) "Cnt" . show) cnts) ++
+ map hImport cs)
+ (mainD outdir a cs fs :
+ map hDataDecl ds ++
+ map hInstD es ++
+ catMaybes (map hTyped ds) ++
+ catMaybes (map hTagged ds) ++
+ map (hVarD a) fs)
+
+hInstD :: P.InstD -> Decl
+hInstD (P.InstD a b) = H.InstDecl nl [] (H.qname a) [hType b] []
+
+mainD :: FilePath -> String -> [ImportD] -> [VarD] -> Decl
+mainD outdir a bs xs = hNameBind "main" $ apps (var "dModule")
+ [ hString outdir
+ , hString a
+ , H.List [ hString b | ImportD b _ <- bs]
+ , H.List $ catMaybes $ map f xs
+ ]
+ where
+ f x = case x of
+ VarD a Define _ -> Just $ apps (var "defn") [var a]
+ _ -> Nothing
+
+hLanguagePragma :: String -> H.ModulePragma
+hLanguagePragma a = H.LanguagePragma nl [H.name a]
+
+hPragmas :: [ModulePragma]
+hPragmas = map hLanguagePragma
+ [ "ScopedTypeVariables", "EmptyDataDecls", "NoMonomorphismRestriction" ]
+
+hUnkindedVar :: Var -> TyVarBind
+hUnkindedVar = H.UnkindedVar . H.name . ppShow
+
+hDataDecl :: TypeD -> Decl
+hDataDecl (TypeD a bs c) = case c of
+ TySyn t -> TypeDecl nl n vs (hType t)
+ _ -> DataDecl nl DataType [] n vs [] []
+ where
+ n = H.name a
+ vs = map hUnkindedVar bs
+
+typeTy :: String -> [Var] -> P.Type
+typeTy a bs = TyConstr a $ map (TyVarT . unVar) bs
+
+eType :: P.Type -> H.Type
+eType x =
+ hTyForall [ hClassA "Typed" [P.Var a] | TyVarT a <- universe x ] $
+ H.TyApp (tyCon "E") $ hType x
+
+hAsst :: Cxt -> Asst
+hAsst (Cxt a bs) = hClassA a bs
+
+hTyVar :: Var -> H.Type
+hTyVar = tyVar . ppShow
+
+hClassA :: String -> [Var] -> Asst
+hClassA a bs = ClassA (qname a) (map hTyVar bs)
+
+unVar :: Var -> Lident
+unVar (P.Var a) = a
+
+hTagged :: TypeD -> Maybe Decl
+hTagged (TypeD a bs c) = case c of
+ TyTagged xs -> f [ d | ConC d _ <- xs ]
+ TyEnum xs -> f [ d | EnumC d <- xs ]
+ _ -> Nothing
+ where
+ f ds = Just $
+ H.InstDecl nl [] (H.qname "Tagged") [hType $ typeTy a bs]
+ [InsDecl $ bind "tags" [PWildCard] $ H.List $ map H.strE ds ]
+
+hTyped :: TypeD -> Maybe Decl
+hTyped (TypeD a bs0 c) = case c of
+ TySyn{} -> Nothing
+ TyUnit{} -> pre
+ [ ty $ var "tyVoid"
+ ]
+ TyNewtype _ t -> pre
+ [ ty $ apps (var "ty") [e]
+ , tydecls $ apps (var "tydecls_") [e]
+ ]
+ where e = hExpTypeSig (var "unused") (hNoAssts $ hType t)
+ TyRecord xs -> pre
+ [ ty $ apps (con "Type") [ H.strE a, H.List [ apps (var "ty") [u]
+ | u <- us ] ]
+ , tydecls $ apps (var "recordTyDecls")
+ [ H.List
+ [ apps (var "tydecls")
+ [hExpTypeSig (var "unused") (hNoAssts $ hType z)]
+ | FieldT _ z <- xs ]
+ , H.List [ tuple
+ [ H.strE y
+ , apps (var "ty")
+ [hExpTypeSig (var "unused") (hNoAssts $ hType z)] ]
+ | FieldT y z <- xs ]
+ ]
+ ]
+ TyTagged xs -> pre
+ [ ty $ apps (var "Type") [ H.strE a
+ , H.List [ apps (var "ty") [u] | u <- us ] ]
+ , tydecls $ apps (var "taggedTyDecls")
+ [ H.List
+ [ apps (var "tydecls")
+ [hExpTypeSig (var "unused") (hNoAssts $ hType z)]
+ | ConC _ z <- xs ]
+ , H.List [ tuple
+ [H.strE y
+ , apps (var "ty")
+ [hExpTypeSig (var "unused") (hNoAssts $ hType z)] ]
+ | ConC y z <- xs ]
+ ]
+ ]
+ TyEnum xs -> pre
+ [ ty $ apps (var "tyPrim") [ H.strE a ]
+ , tydecls $ apps (var "enumTyDecls")
+ [H.List [ H.strE y | EnumC y <- xs ]]
+ ]
+ where
+ bs = bs0 `intersect` [ P.Var b | TyVarT b <- universeBi c]
+ us = map (hExpTypeSig (var "unused") . hTyVar) bs
+ assts =
+ nub $ map (\b -> hClassA "Typed" [b]) bs0 ++
+ [hAsst cxt | cxt@Cxt{} <- universeBi c]
+ pre =
+ Just . H.InstDecl nl assts (H.qname "Typed") [hType $ typeTy a bs0]
+ ty v = InsDecl $ bind "ty" [PWildCard] v
+ tydecls v = InsDecl $ bind "tydecls" [] v
+
+hExport :: ExportD -> ExportSpec
+hExport x = case x of
+ TypeEx a -> EThingAll (qname a)
+ VarEx a -> EVar (qname a)
+
+hImport_ :: String -> ImportDecl
+hImport_ a = hImport (ImportD a EmptyAS)
+
+hImport :: ImportD -> ImportDecl
+hImport (ImportD a b) = ImportDecl
+ { importLoc = nl
+ , importModule = ModuleName a
+ , importQualified = x
+ , importSrc = False
+ , importPkg = Nothing
+ , importAs = Just $ ModuleName y
+ , importSpecs = Nothing
+ }
+ where
+ (x,y) = case b of
+ EmptyAS -> (False,a)
+ AsAS c -> (True,c)
+
+hVarD :: String -> VarD -> Decl
+hVarD m (VarD a b c) = case b of
+ Macro -> hNameBind a (hExp True c)
+ Define -> hNameBind a $ term "defE" [hString n, hExp False c]
+ where
+ n | a == "main_" = a
+ | otherwise = m ++ a
+
+hNameBind :: String -> H.Exp -> Decl
+hNameBind a = nameBind nl (Ident a)
+
+hChar :: Char -> H.Exp
+hChar = Lit . Char
+
+hLit :: Lit -> H.Exp
+hLit x = case x of
+ CharL a -> term "charE" [hChar a]
+ StringL a -> term "stringE" [hString a]
+ NmbrL a -> term "nmbrE" [hString a]
+
+term :: String -> [H.Exp] -> H.Exp
+term a bs = apps (var a) bs
+
+hExpTypeSig :: H.Exp -> H.Type -> H.Exp
+hExpTypeSig a b = Paren (ExpTypeSig nl a b)
+
+hLambda :: Pat -> H.Exp -> H.Exp
+hLambda p e = Lambda nl [p] e
+
+hTyTuple :: [H.Type] -> H.Type
+hTyTuple = TyTuple Boxed
+
+hLet :: String -> H.Exp -> H.Exp -> H.Exp
+hLet a b c = Let (BDecls [hNameBind a b]) c
+
+hExp :: Bool -> P.Exp -> H.Exp
+hExp r x = case x of
+ SwitchE a mb cs -> case mb of
+ DefaultSome b -> term "switchE" [y, hExp r b, z]
+ DefaultNone -> term "switchE_" [y, z]
+ where
+ y = hExp r a
+ z = List [tuple [hExp r m, hExp r n] | SwitchAlt m n <- cs]
+ LetE a b c d -> case b of
+ Macro -> hLet a (hExp True c) (hExp r d)
+ Define -> term "letE" [ hNameStr r a
+ , hExp r c
+ , hLambda (H.pVar a) (hExp r d) ]
+ LamE a b -> term "lamE" [hNameStr r a, hLambda (H.pVar a) (hExp r b)]
+ AppE a b -> term "appE" [hExp r a, hExp r b]
+ VarE a -> var a
+ LitE a -> hLit a
+ AscribeE a b -> hExpTypeSig (hExp r a) (eType b)
+
+hNameStr :: Bool -> [Char] -> H.Exp
+hNameStr inMacro a = hString s
+ where s = if inMacro then "~" ++ a else a -- this allows for more readable code generation (procedure variable names are prefered over macro variable names)
+
+hAssts :: H.Type -> [Asst]
+hAssts x = nub $ case x of
+ TyForall _ b c -> b ++ hAssts c
+ H.TyFun a b -> hAssts a ++ hAssts b
+ TyTuple _ bs -> concatMap hAssts bs
+ TyList a -> hAssts a
+ TyApp a b -> hAssts a ++ hAssts b
+ TyVar{} -> []
+ TyCon{} -> []
+ TyParen a -> hAssts a
+ TyInfix a _ c -> hAssts a ++ hAssts c
+ TyKind a _ -> hAssts a
+
+hNoAssts :: H.Type -> H.Type
+hNoAssts x = case x of
+ TyForall _ _ c -> hNoAssts c
+ H.TyFun a b -> H.TyFun (hNoAssts a) (hNoAssts b)
+ TyTuple a bs -> TyTuple a $ map hNoAssts bs
+ TyList a -> TyList (hNoAssts a)
+ TyApp a b -> TyApp (hNoAssts a) (hNoAssts b)
+ TyVar{} -> x
+ TyCon{} -> x
+ TyParen a -> TyParen $ hNoAssts a
+ TyInfix a b c -> TyInfix (hNoAssts a) b (hNoAssts c)
+ TyKind a b -> TyKind (hNoAssts a) b
+
+hTyForall :: [Asst] -> H.Type -> H.Type
+hTyForall x = hFixType . TyForall Nothing x
+
+hFixType :: H.Type -> H.Type
+hFixType x = case hAssts x of
+ [] -> x
+ cxt -> TyForall Nothing (nub cxt) $ hNoAssts x
+
+hType :: P.Type -> H.Type
+hType x = hFixType $ case x of
+ TyCxt ys z -> hTyForall (map hAsst ys) (hType z)
+ P.TyFun a b -> H.TyFun (hType a) (hType b)
+ TyVoid -> hTyTuple []
+ TyConstr a bs -> tyApps (tyCon a) $ map hType bs
+ TyVarT a -> tyVar a
diff --git a/src/PecGenCnt.hs b/src/PecGenCnt.hs
new file mode 100644
--- /dev/null
+++ b/src/PecGenCnt.hs
@@ -0,0 +1,59 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- The pec embedded compiler
+-- Copyright 2011-2012, Brett Letner
+
+module Main where
+
+import Data.Char
+import Grm.Prims
+import Pec.HUtil
+import Pec.PUtil
+import System.Console.CmdArgs
+import System.FilePath
+import qualified Language.Haskell as H
+
+data Args = Args
+ { targets :: [String]
+ } deriving (Show, Data, Typeable)
+
+main :: IO ()
+main = do
+ a <- cmdArgs argsDesc
+ case targets a of
+ [] -> putStrLn $ summarize prog
+ xs -> mapM_ hCountModule xs
+
+hCountModule :: FilePath -> IO ()
+hCountModule fn0 = do
+ writeFileBinary (joinPath [d,fn]) $ H.prettyPrint $
+ hmodule n ["EmptyDataDecls"] Nothing
+ [ importDecl_ False "Pec.Base" ]
+ [ hdatadecl n [] []
+ , hinstdecl [] "Count" [H.tyCon n]
+ [H.InsDecl $
+ H.simpleFun nl (H.name "countof") (H.name "_") (H.intE i)]
+ , hinstdecl [] "Typed" [H.tyCon n]
+ [ H.InsDecl $
+ H.simpleFun nl (H.name "ty") (H.name "_")
+ (H.App (H.var "tyCnt") (H.intE i))
+ ]
+ , H.nameBind nl (H.Ident m) $ H.ExpTypeSig nl
+ (H.App (H.var "varE") (hString m)) $
+ H.TyApp (H.tyCon "E") (H.tyCon n)
+ ]
+ where
+ d = takeDirectory fn0
+ i = read $ filter isDigit $ takeBaseName fn0
+ n = "Cnt" ++ show i
+ m = lowercase n
+ fn = n ++ ".hs"
+
+argsDesc :: Args
+argsDesc = Args
+ { targets = def &= args
+ } &= summary (summarize prog) &= program prog
+
+prog :: String
+prog = "pecgencnt"
diff --git a/test_cases/Makefile b/test_cases/Makefile
deleted file mode 100644
--- a/test_cases/Makefile
+++ /dev/null
@@ -1,16 +0,0 @@
-.SUFFIXES :
-
-all : clean TestStack.exe TestStrBuf.exe TestPrims.exe TestTuple.exe TestVariant.exe TestArray.exe TestLoad.exe # T.exe
- pec
- pec --version
- pec --help
-
-%.exe : %.pec
- pec -k $<
- ./$@
-
-clean :
- rm -f *.bc *.ll *.exe *.s *.out *~ *.tix
-
-vclean : clean
- rm -f Cnt*.hs *.o *.hi *_.hs *_main.hs
diff --git a/test_cases/TestArray.pec b/test_cases/TestArray.pec
--- a/test_cases/TestArray.pec
+++ b/test_cases/TestArray.pec
@@ -1,69 +1,139 @@
-module TestArray exports all
-
-where
-
-import Prelude
-
-// fixed sized arrays
-
-garr = Array [ 'a', 'b', 'c' ]
-
-main :: () -> W32
-main () = do
- testSingleDim ()
- testMultiDim ()
- 0
-
-testSingleDim () = do
- putLn "testSingleDim"
- arr = new Array [ 'x', 'y', 'z' ]
- assert (@arr[0] == 'x')
- putCh @arr[0] // index operator. returns pointer to given index
- putCh @arr[1]
- putCh @arr[2]
-// the index operator is type safe, i.e. putCh @arr[3] will fail to compile.
- arr[0] <- 'a' // store an 'a' at element 0
- arr[1] <- 'b'
- arr[2] <- 'c'
- putCh @arr[0]
- putCh @arr[1]
- putCh @arr[2]
- assert (@arr[0] == 'a')
- arr <- Array [ 'x', 'y', 'z' ]
- putCh @arr[0]
- putCh @arr[1]
- putCh @arr[2]
- assert (@arr[2] == 'z')
- assert (@(new garr)[1] == 'b')
- arr2 = new (array #5 'c')
- assert (@arr2[4] == 'c')
- putCh @arr2[0]
- putCh @arr2[4]
- putLn "done"
-
-arrayf :: Ptr (Array #2 Bool) -> ()
-arrayf arr = do
- assert @arr[0]
- assert (not @arr[1])
-
-testMultiDim () = do
- putLn "testMultiDim"
- arr = new Array [ Array [ 'a', 'b' ]
- , Array [ 'c', 'd' ]
- , Array [ 'e', 'f' ] ]
- putCh @arr[0][0]
- putCh @arr[0][1]
- putCh @arr[1][0]
- putCh @arr[1][1]
- putCh @arr[2][0]
- putCh @arr[2][1]
- assert True
- (a :: Ptr Bool) = new True
- assert @a
- b = new Array [ True ]
- assert @b[0]
- x = new Array [ Array [ Array [ True ] ], Array [ Array [ False ] ] ]
- assert @x[0][0][0]
- assert (not @x[1][0][0])
- () = arrayf (new (Array [ True, False ]))
- (putLn "done" :: ())
+module TestArray
+
+imports
+ Prelude
+ Data.Array
+
+where
+
+// fixed sized arrays
+
+garr => Array [ 'a', 'b', 'c' ]
+
+main :: () -> I32
+main () = do
+ putLn "testArray"
+ testSingleDim ()
+ testMultiDim ()
+ testOps ()
+ 0
+
+testSingleDim () = do
+ putLn "testSingleDim"
+ arrval = Array [ 'x', 'y', 'z' ]
+ arr = new (arrval :: Array #3 Char)
+ put putCh arr
+ assert (@arr[0] == 'x')
+ putCh @arr[0] // index operator. returns pointer to given index
+ putCh @arr[1]
+ putCh @arr[2]
+ alsoarr = new arrval
+ put putCh alsoarr
+ assert (@alsoarr[0] == 'x')
+ assert (@alsoarr[1] == 'y')
+ assert (@alsoarr[2] == 'z')
+ // the index operator is type safe, i.e. putCh @arr[3] will fail to compile.
+ arr[0] <- 'a' // store an 'a' at element 0
+ arr[1] <- 'b'
+ arr[2] <- 'c'
+ put putCh arr
+ putCh @arr[0]
+ putCh @arr[1]
+ putCh @arr[2]
+ assert (@arr[0] == 'a')
+ assert (@arr[1] == 'b')
+ assert (@arr[2] == 'c')
+ assert (@alsoarr[0] == 'x')
+ assert (@alsoarr[1] == 'y')
+ assert (@alsoarr[2] == 'z')
+ arr <- Array [ 'x', 'y', 'z' ]
+ put putCh arr
+ putCh @arr[0]
+ putCh @arr[1]
+ putCh @arr[2]
+ assert (@arr[2] == 'z')
+ assert (@(new garr)[1] == 'b')
+ arr2 = new (array #5 'c')
+ assert (@arr2[4] == 'c')
+ putCh @arr2[0]
+ putCh @arr2[4]
+ arr3 = new (array #2 True)
+ arr3[1] <- False
+ arrayf arr3
+ arrayf2 arr3
+ putLn "done"
+
+arrayf :: Ptr (Array #2 Bool) -> ()
+arrayf arr = do
+ assert @arr[0]
+ assert (not @arr[1])
+
+arrayf2 :: Ptr (Array #2 Bool) -> ()
+arrayf2 p = arrayf p
+
+testMultiDim () = do
+ putLn "testMultiDim"
+ arr = new Array
+ [ Array [ 'a', 'b' ]
+ , Array [ 'c', 'd' ]
+ , Array [ 'e', 'f' ]
+ ]
+ putCh @arr[0][0]
+ putCh @arr[0][1]
+ putCh @arr[1][0]
+ putCh @arr[1][1]
+ putCh @arr[2][0]
+ putCh @arr[2][1]
+ assert True
+ (a :: Ptr Bool) = new True
+ assert @a
+ b = new Array [ True ]
+ assert @b[0]
+ x = new Array [ Array [ Array [ True ] ], Array [ Array [ False ] ] ]
+ assert @x[0][0][0]
+ assert (not @x[1][0][0])
+ () = arrayf (new (Array [ True, False ]))
+ (p :: Ptr (Array #1 (Array #1 Bool))) = x[0]
+ assert @p[0][0]
+ (q :: Ptr (Array #1 Bool)) = x[0][0]
+ assert @q[0]
+ (r :: Ptr (Array #1 Bool)) = p[0]
+ assert @r[0]
+ (putLn "done" :: ())
+
+sum => fold add 0
+
+testOps :: () -> ()
+testOps () = do
+ putLn "testOps"
+ arr = new (Array [ (1 :: W32), 2, 3])
+ t = new (sum arr)
+ assert (@t == 6)
+
+ foreach inc arr
+ t <- sum arr
+ assert (@t == 9)
+
+ mi = new (find_idx (eq 0) arr)
+ case mi of
+ Nothing -> assert True
+ Just _ -> assert False
+
+ mi <- find_idx (eq 4) arr
+ case mi of
+ Nothing -> assert False
+ Just i -> assert (@i == 2)
+
+/*
+// There is no good reason that the following shouldn't work. It's just a pain to generate the required C code.
+retArray :: () -> Array #2 Char
+retArray () = Array [ 'p', 'q' ]
+
+argArray :: Array #2 Char -> Bool
+argArray arr = do
+ p = new arr
+ @p[1] == 'q'
+
+ptrArray :: Ptr (Array #2 Bool) -> Ptr (Array #2 Bool)
+ptrArray a = a
+*/
diff --git a/test_cases/TestLoad.pec b/test_cases/TestLoad.pec
--- a/test_cases/TestLoad.pec
+++ b/test_cases/TestLoad.pec
@@ -1,13 +1,14 @@
-module TestLoad exports all
-
-where
-
-import Prelude
-
-main :: () -> I32
-main () = do
- p = new 'a'
- assert (@p == 'a')
- putCh @p
- putCh '\n'
- 0
+module TestLoad
+
+imports
+ Prelude
+
+where
+
+main :: () -> I32
+main () = do
+ p = new 'a'
+ assert (@p == 'a')
+ putCh @p
+ putCh '\n'
+ 0
diff --git a/test_cases/TestPrims.pec b/test_cases/TestPrims.pec
--- a/test_cases/TestPrims.pec
+++ b/test_cases/TestPrims.pec
@@ -1,51 +1,28 @@
module TestPrims // module declaration
-exports all // export declaration
+imports
+ Prelude // import declaration. pulls in the declarations from Prelude.pec
where
-import Prelude // import declaration. pulls in the declarations from Prelude.pec
-
// single line comment
-// some top-level declarations.
-// non-function top-level decls are
-// simply inlined
-
-gchar :: Char // type signature like in Haskell
-gchar = 'a'
- // char literal
- // chars are are char, not ints like in C
-
-gi32 :: I32 // 32 bit integer
-gi32 = (3 :: I32) // type ascription
-// pec can have arbitrary sized ints and uints, like in llvm
-
-gw16 = (12 :: W16) // 16 bit word (unsigned int)
-gw16_2 = gw16 + 1
-
-gbool :: Bool // boolean type
-gbool = True
-// booleans aren't primitive, they are defined in Prelude.pec
-
-gistring :: IString
-gistring = "global istring"
-// string literals are IStrings, immutable strings
-// comparison is O(1)
+/*
+ multi-line comment
+ /*
+ nests properly
+ */
+*/
-gSideEffect :: Bool
-gSideEffect = do
- putLn "side effect" // print an IString to the screen
- True
-// pec is impure.
-// This definition will get inlined
+// some top-level declarations.
+// macro decls (i.e. the ones with the "=>") are simply inlined
// "do" notation, similar to haskell
// in pec it is syntactic sugar for let [v=e] in r
// where r is the "return" value
// note the 0 at the end
-main :: () -> W32
+main :: () -> I32
// main has type function of () to W32
// where () is the type 'unit' (similar to void in C)
main () = do // unit pattern match
@@ -59,19 +36,51 @@
putLn "...test complete"
0
+gchar :: Char // type signature like in Haskell
+gchar => 'a'
+ // char literal
+ // chars are type char, not ints like in C
+
+gi32 :: I32 // 32 bit integer
+gi32 => (3 :: I32) // type ascription
+// pec can have arbitrary sized ints and uints, like in llvm
+
+gw16 => (12 :: W16) // 16 bit word (unsigned int)
+gw16_2 => gw16 + 1
+
+gbool :: Bool // boolean type
+gbool => True
+// booleans aren't primitive, they are defined in Prelude.pec
+
+gistring :: IString
+gistring => "global istring"
+// string literals are IStrings, immutable strings
+
+gSideEffect :: Bool
+gSideEffect => do
+ putLn "side effect" // print an IString to the screen
+ True
+// pec is impure.
+// This definition will get inlined.
+
testI32 :: () -> ()
testI32 () = do
putLn "testI32"
assert (gi32 == 3) // assert is just a library function
assert ((0 :: I32) == 0) // type ascription
+ assert (0xFF == (0o377 :: I32))
+ assert (0Xff == (0b11111111 :: I32))
putLn "done"
testDouble :: () -> ()
testDouble () = do
putLn "testDouble"
- assert ((0 :: Double) >= 0)
- assert (((-1) :: Float) >= (-1.0)) // floats aren't working at the moment
-// fixme: doesn't work. need ieee754 library or just some prelude functions? assert (((-1) :: Float) >= (-1.1))
+ assert ((0 :: Double) >= 0x0)
+ assert (((-1) :: Float) >= (-1.0))
+// broken in llvm version: assert (((-1) :: Float) >= (-1.1))
+ assert (((-1) :: Float) >= (-1.25))
+ assert (((-0.1) :: Double) < (-0.0))
+ assert ((10e-2 :: Double) >= (-9.1e-1))
assert (gi32 == 3)
putLn "done"
@@ -83,26 +92,25 @@
// names in pec are single static assignment (SSA)
// i.e. x has a constant value
-// case statment, similar to Haskell
-// like a more powerful C switch statement
- case x of
+// like a C switch statement
+ switch x of
4 -> assert True // pattern on the left, expression on the right
_ -> assert False // default
- case (7 :: W16) of // type ascription can be most anywhere
+ switch (7 :: W16) of // type ascription can be most anywhere
4 -> assert False
7 -> assert True
_ -> assert False
p = new (3 :: W16) // 'new' allocates memory on the stack and stores the given value there. p :: Ptr W16
- case @p of // '@' is the load operator. It returns the value stored at the given location.
+ switch @p of // '@' is the load operator. It returns the value stored at the given location.
3 -> assert True
_ -> assert False
p <- 12 // '<-' is the store operator. It takes a value and stores it at the given location.
- case @p of
+ switch @p of
3 -> assert False
x -> assert (x == 12)
@@ -112,10 +120,10 @@
// branch expression. like switch except each arm has a boolean operator.
// Its purpose in life is to reduce the number of nested ifs.
- branch of
- | @p < 3 -> assert False // boolean expression on the left, value on the right
- | False -> assert False
- | -> assert True // all branch expressions must have a default
+ branch
+ @p < 3 -> assert False // boolean expression on the left, value on the right
+ False -> assert False
+ | assert True // all branch expressions must have a default
putLn "done"
@@ -137,24 +145,31 @@
testIString :: () -> ()
testIString () = do
putLn "testIString"
- // IStrings are just represented in a global table,
- // so they can be compared by their index value
assert ("hi" == "hi")
assert (gistring == "global istring")
- case "hi" of
+ switch "hi" of
"bye" -> assert False
"hi" -> assert True
- s -> do // default pattern match, so that we can use the case scrutinee
+ s -> do // default pattern match, so that we can use the switch scrutinee
putLn s
assert False
s = "blah" // at a different scope than the previous "s". This feature might be removed in the future.
- case s of
+ switch s of
"blah" -> assert (s == "blah")
_ -> assert False
putLn "done"
type MyChar a = Char // polymorphic type
+getT :: () -> Char
+getT (()) = 'T' // same as getT (), just getting coverage on that pattern
+
+funptr :: (Char -> Bool) -> Char -> Bool // type of a function that takes a function argument, a character, and returns a bool
+funptr f c = f c
+
+funptr2 :: (Char -> Char) -> Char -> Char
+funptr2 f c = f c
+
testChar :: () -> ()
testChar () = do // character literals
putLn "testChar"
@@ -165,12 +180,12 @@
if ('m' == 'm') (putCh 't') (putCh 'f')
- case 'm' of
+ switch 'm' of
'n' -> putCh 'n'
'm' -> putCh 't'
v -> putCh v
- case 't' of
+ switch 't' of
'm' -> putCh 'm'
'n' -> putCh 'n'
v -> putCh v
@@ -178,13 +193,9 @@
x = 't'
putCh x
-// "if" function call.
-// "if" is not a primitive, it is defined using the "library" DSL, so that it can be polymorphic and lazy
-// see "if_" in Prelude.pec
-
if (x != 'm') (putCh 't') (putCh 'f')
- case x of
+ switch x of
'm' -> putCh 'm'
'n' -> putCh 'n'
v -> putCh v
@@ -197,7 +208,7 @@
(putCh 'f')
(putCh 't')
- case @p of
+ switch @p of
'm' -> putCh 'm'
'n' -> putCh 'n'
v -> do
@@ -220,7 +231,7 @@
putCh @p
- p <- case 'l' of
+ p <- switch 'l' of
'l' -> 't'
'n' -> 'n'
_ -> 'a'
@@ -248,13 +259,12 @@
assert (is_lower w)
assert (is_upper x)
putCh '\n'
+ f = pickfun True
+ assert (f 'a')
+ g = pickfun False
+ assert (g 'B')
putLn "done"
-getT :: () -> Char
-getT (()) = 'T'
-
-funptr :: (Char -> Bool) -> Char -> Bool // type of a function that takes a function pointer argument, a character, and returns a bool
-funptr f c = f c
+pickfun :: Bool -> (Char -> Bool) // returning a function
+pickfun x = if x is_lower is_upper
-funptr2 :: (Char -> Char) -> Char -> Char
-funptr2 f c = f c
diff --git a/test_cases/TestStack.pec b/test_cases/TestStack.pec
--- a/test_cases/TestStack.pec
+++ b/test_cases/TestStack.pec
@@ -1,39 +1,127 @@
-module TestStack exports all
+module TestStack
-where
+// polymorphic stack implementation
-// polymorphic Stack implementation
+imports
+ Prelude
+ Data.Stack
-import Prelude
-import Stack
+where
-main :: () -> W32
+main :: () -> I32
main () = do
putLn "test Stack"
p = new (stack #3) // stacks must be given a size
- case new (pop p) of
+ put putCh p
+ mc = new (pop p)
+ case mc of
Nothing -> assert True
Just _ -> assert False
assert (push 'a' p)
+ put putCh p
case new (pop p) of
Nothing -> assert False
Just c -> do
putCh @c
assert (@c == 'a')
+ put putCh p
assert (is_empty p)
assert (push 'a' p)
+ put putCh p
assert (push 'b' p)
+ put putCh p
assert (push 'c' p)
+ put putCh p
assert (is_full p)
assert (not (push 'd' p))
- mc = new (pop p)
+ mc <- pop p
+ put putCh p
case mc of
Nothing -> assert False
Just c -> do
putCh @c
assert (@c == 'c')
mc <- pop p
+ put putCh p
mc <- pop p
+ put putCh p
assert (is_empty p)
+ assert (push 'x' p)
+ assert (push 'y' p)
+ put putCh p
+ mc <- pop p
+ case mc of
+ Nothing -> assert False
+ Just c -> assert (@c == 'y')
+
+ mc <- pop p
+ case mc of
+ Nothing -> assert False
+ Just c -> assert (@c == 'x')
+
+ put putCh p
+ w = new (stack #6 :: Stack #6 W32)
+ assert (push 0 w)
+ assert (push 1 w)
+ assert (push 2 w)
+
+ t = new 0
+ t <- sum w
+ assert (@t == 3)
+
+ foreach inc w
+
+ t <- sum w
+ assert (@t == 6)
+
+ assert (push 1 w)
+ assert (push 2 w)
+ assert (push 1 w)
+
+ t <- sum w
+ assert (@t == 10)
+
+ mpw = new (find (eq 1) w)
+ case mpw of
+ Nothing -> assert False
+ Just pw -> @pw <- 2
+
+ put putW w
+
+ t <- sum w
+ assert (@t == 11)
+
+ filter (eq 2) w
+ t <- sum w
+ assert (@t == 6)
+ put putW w
+
putLn "done"
0
+
+test_ops :: () -> ()
+test_ops () = do
+ putLn "test_ops"
+ stck = new (stack #3 :: Stack #3 W32)
+ assert (push 1 stck)
+ assert (push 2 stck)
+ assert (push 3 stck)
+
+ t = new (sum stck)
+ assert (@t == 6)
+
+ foreach inc stck
+ t <- sum stck
+ assert (@t == 9)
+
+ mi = new (find_idx (eq 0) stck)
+ case mi of
+ Nothing -> assert True
+ Just _ -> assert False
+
+ mi <- find_idx (eq 4) stck
+ case mi of
+ Nothing -> assert False
+ Just i -> assert (@i == 2)
+
+sum => fold add 0
diff --git a/test_cases/TestStrBuf.pec b/test_cases/TestStrBuf.pec
--- a/test_cases/TestStrBuf.pec
+++ b/test_cases/TestStrBuf.pec
@@ -1,16 +1,17 @@
-module TestStrBuf exports all
+module TestStrBuf
-where
+// String buffers, like char sbuf[N] in C except we don't have to worry about a missing null terminator
-import Prelude
-import StrBuf
+imports
+ Prelude
+ Data.StrBuf
-// String buffers, like char sbuf[N] in C except we don't have to worry about a missing null terminator
+where
-main :: () -> W32
+main :: () -> I32
main () = do
putLn "test StrBuf"
- p = new (strbuf #5) // declaring an empty string buffer requires a singleton "Count" value
+ p = new (strbuf #6) // will hold strings of length 5
assert (strlen p == 0)
put p
assert (to_strbuf "BL" p) // to_strbuf returns True if all the characters were copied
@@ -22,24 +23,24 @@
assert (not (to_strbuf "Letner" p)) // to_strbuf returns False if not all the characters were able to be copied.
assert (strlen p == 5)
put p
- q = new (strbuf #6)
+ q = new (strbuf #7)
assert (to_strbuf "Letner" q)
assert (strlen q == 6)
put q
- case strcmp p q of
+ switch strcmp p q of
LT -> assert True
EQ -> assert False
GT -> assert False
assert (to_strbuf "Letne" q)
- puts (from_strbuf p)
- puts (from_strbuf q)
- case strcmp p q of
+ put p
+ put q
+ switch strcmp p q of
EQ -> assert True
_ -> assert False
- to_strbuf "foo" p
+ assert (to_strbuf "foo" p)
put p
put q
- strcpy p q
+ assert (strcpy p q)
put q
assert (strcmp p q == EQ)
putLn "done"
diff --git a/test_cases/TestTuple.pec b/test_cases/TestTuple.pec
--- a/test_cases/TestTuple.pec
+++ b/test_cases/TestTuple.pec
@@ -1,12 +1,13 @@
-module TestTuple exports all
+module TestTuple
-where
+imports
+ Prelude
-import Prelude
+where
// () is a tuple with no elements.
-// it gets compiled as "void" in the LLVM code
-main :: () -> W32
+// it gets compiled as "void" in the LLVM/C code
+main :: () -> I32
main () = do
testUnit ()
testPair ()
@@ -28,14 +29,12 @@
testPair :: () -> ()
testPair () = do
p = new ('a',True) // p :: Ptr (Char, Bool)
-
(c,b) = p // pattern match. note that c :: Ptr Char and b :: Ptr Bool
putCh @c
putCh @p.fst // using record syntax to extract the first element of a pair
// note that it returns a pointer to the element within the record
- putCh @(fst p) // using function syntax for the same thing
+ putCh @(fst p) // using a function to do the same thing
assert @b
-
c <- 'b'
b <- False
putCh @c
@@ -81,11 +80,12 @@
tuplef (new (True, 'c', 7))
putLn "done"
-type Person = // the standard record example
+type Person = // record example
{ name :: IString
, middle_initial :: Char
, city :: IString
- , zipcode :: W32 }
+ , zipcode :: W32
+ }
// order of elements doesn't matter, so this is exactly the same as
// type Person =
// { zipcode :: W32
@@ -107,8 +107,8 @@
assert (@p.stuff == 'b')
putCh @p.stuff
y = { name = "Brett", city = "Beverly Hills", zipcode = 90210, middle_initial = 'A' }
-// since pec has side effects, record labels are sorted prior to execution.
-// having a side effecting function within a record initilization is considered bad form :)
+// record labels are always placed in canonical order (i.e. sorted by name)
+// side-effecting functions should not be used within a record initilization
q = new y
putLn @q.name
diff --git a/test_cases/TestVariant.pec b/test_cases/TestVariant.pec
--- a/test_cases/TestVariant.pec
+++ b/test_cases/TestVariant.pec
@@ -1,28 +1,35 @@
-module TestVariant exports all
+module TestVariant
-where
+imports
+ Prelude
-import Prelude
+where
-main :: () -> W32
+main :: () -> I32
main () = do
testEnum ()
testNewtype ()
testNewtypePoly ()
- testVariant ()
testUnit ()
+ testVariant ()
0
-type Color = | Red | Blue | Green // the standard enum example
+type Color = | Red | Blue | Green // the standard enum example, order doesn't matter
+type PHColor x = | PHRed | PHBlue // phantom type enum
+
+instance Eq Color // eq and ne can be derived for enums
+instance Eq (PHColor x)
+
+// enums can't be automatically cast to ints, that leads to maintenance problems
unColor :: Color -> W32
-unColor c = case c of
+unColor c = switch c of
Red -> 0
Blue -> 1
- Green -> 2
+ Green -> 2 // All tags must be matched. Removing this line will cause a compile time error.
sColor :: Color -> IString
-sColor c = case c of // case on enums is by value
+sColor c = switch c of // switch on enums is by value
Red -> "Red"
Blue -> "Blue"
Green -> "Green"
@@ -38,9 +45,9 @@
testUnit :: () -> ()
testUnit () = do
putLn "testunit"
- x = Unit // singleton types are compiled into "void" in LLVM
+ x = Unit // singleton types are compiled into "void" in LLVM/C
unita x
- unitf ()
+ _ = unitf ()
unita Unit
putLn "done"
@@ -48,7 +55,7 @@
testEnum () = do
putLn "testEnum"
assert (Red == Red)
- x = Green // enum types are compiled into unsigned ints in LLVM
+ x = Green // enum types are compiled into unsigned ints in LLVM/C
putLn (sColor x)
assert (Green == x)
assert (x == Green)
@@ -64,30 +71,29 @@
assert (@p == Green)
assert (unColor @p == 2)
assert (unColor Blue == 1)
- case Red of
+ switch Red of
Green -> assert False
Red -> assert True
color -> assert (color != Blue)
- case x of
+ switch x of
Green -> assert True
Red -> assert False
Blue -> assert False
+ pc = (PHRed :: PHColor Bool)
+ assert (pc == PHRed)
+// assert (pc == (PHRed :: PHColor ())) // type error
putLn "done"
type Meters = | M W32 // newtype. A variant with only one tag
->instance EQ Meters_ where
-> eq = unwrap2 eq
-> ne = unwrap2 ne
-
-type MyA a = | My a // polymorphic newtype
+instance Eq Meters
testNewtype :: () -> ()
testNewtype () = do
putLn "testNewtype"
assert (M 7 == M 7)
// newtypes are constructed by juxtaposition like in Haskell
-// newtypes are compiled into whatever the underlying type is in LLVM (i.e. the tag is eliminated)
+// newtypes are compiled into whatever the underlying type is in LLVM/C (i.e. the tag is eliminated)
x = M 12
assert (x == M 12)
p = new (M 7)
@@ -95,20 +101,22 @@
assert (@p == M 7)
p <- M 47
assert (@p == M 47)
- assert (47 == unwrap @p) // instead of using "case" to extract values from newtypes, pec provides the polymorphic "unwrap" function
+ assert (47 == m_unwrap @p) // instead of using "case" to extract values from newtypes, a function is created which will unwrap the type, it has the form _unwrap. Also _unwrapptr is created which will safely cast a newtype ptr to a ptr.
p <- M 1
- i = unwrap @p
+ i = m_unwrap @p
assert (i == 1)
putLn "done"
+type MyA a = | My a // polymorphic newtype
+
testNewtypePoly :: () -> ()
testNewtypePoly () = do
putLn "testNewtypePoly"
x = My 'c'
p = new x
- assert (unwrap @p == 'c')
+ assert (my_unwrap @p == 'c')
q = new (My True)
- assert (unwrap @q)
+ assert (my_unwrap @q)
putLn "done"
testVariant :: () -> ()
@@ -116,7 +124,7 @@
putLn "testVariant"
p = new (Left False)
p <- Right 'c' // p :: Ptr (Either Bool Char)
-// variants must be accessed via a pointer
+ // variants must be accessed via a pointer
case p of
Left a -> do
assert @a
@@ -129,7 +137,7 @@
Right b -> do
putCh @b
assert False
- q = new Nothing
+ q = new (Nothing :: Maybe Bool)
case q of
Nothing -> assert True
Just _ -> assert False
@@ -137,4 +145,14 @@
case q of
Just b -> assert @b
_ -> assert False
+ r = new (Left True)
+ case r of
+ Left b -> assert @b
+ Right _ -> assert False
+ r <- Right (27 :: W32)
+ case r of
+ Left _ -> assert False
+ Right i -> do
+ putW @i
+ assert True
putLn "done"