pec 0.1.1 → 0.2.0
raw patch · 58 files changed
+7038/−7537 lines, 58 filesdep +containersdep +deepseqdep +grmdep ~basesetup-changednew-component:exe:pecgennew-component:exe:pecgencnt
Dependencies added: containers, deepseq, grm, old-time, pec, shake, syb, uniplate, wl-pprint
Dependency ranges changed: base
Files
- C.grm +85/−0
- CHANGES +7/−0
- DESIGN +71/−103
- FAQ +101/−82
- LICENSE +30/−30
- LLVM.grm +131/−0
- Language/C/Abs.hs +194/−0
- Language/LLVM/Abs.hs +293/−0
- Language/Pds/Abs.hs +209/−0
- Language/Pec/Abs.hs +494/−133
- Language/Pec/Doc.html +0/−695
- Language/Pec/ErrM.hs +0/−26
- Language/Pec/Layout.hs +0/−262
- Language/Pec/Lex.x +0/−156
- Language/Pec/Par.hs +0/−3137
- Language/Pec/Par.y +423/−0
- Language/Pec/Print.hs +0/−314
- Language/Pir/Abs.hs +175/−0
- Main.hs +0/−727
- Makefile +4/−45
- MkPec.hs +124/−0
- Pds.grm +78/−0
- Pec.cf +0/−136
- Pec.grm +175/−0
- Pec/Base.hs +707/−598
- Pec/C.hs +610/−0
- Pec/Desugar.hs +455/−0
- Pec/HUtil.hs +48/−0
- Pec/IUtil.hs +159/−0
- Pec/LLVM.hs +427/−0
- Pec/Makefile +0/−2
- Pec/PUtil.hs +91/−0
- Pir.grm +68/−0
- README +42/−37
- Setup.hs +6/−8
- THANKS +17/−16
- TODO +73/−55
- dist/build/pec/pec-tmp/Language/Pec/Lex.hs +0/−361
- lib/Data/Array.pec +90/−0
- lib/Data/Deque.pec +167/−0
- lib/Data/Queue.pec +81/−0
- lib/Data/Stack.pec +119/−0
- lib/Data/StrBuf.pec +45/−0
- lib/Prelude.pec +255/−244
- lib/Stack.pec +0/−50
- lib/StrBuf.pec +0/−48
- pec.cabal +48/−46
- src/Pec.hs +168/−0
- src/PecGen.hs +311/−0
- src/PecGenCnt.hs +59/−0
- test_cases/Makefile +0/−16
- test_cases/TestArray.pec +139/−69
- test_cases/TestLoad.pec +14/−13
- test_cases/TestPrims.pec +78/−68
- test_cases/TestStack.pec +96/−8
- test_cases/TestStrBuf.pec +15/−14
- test_cases/TestTuple.pec +12/−12
- test_cases/TestVariant.pec +44/−26
+ C.grm view
@@ -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
+ CHANGES view
@@ -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
DESIGN view
@@ -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.
FAQ view
@@ -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.
LICENSE view
@@ -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.
+ LLVM.grm view
@@ -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
+ Language/C/Abs.hs view
@@ -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
+ Language/LLVM/Abs.hs view
@@ -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
+ Language/Pds/Abs.hs view
@@ -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
Language/Pec/Abs.hs view
@@ -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
− Language/Pec/Doc.html
@@ -1,695 +0,0 @@-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> -<HTML> -<HEAD> -<META NAME="generator" CONTENT="http://txt2tags.org"> -<TITLE>The Language Pec</TITLE> -</HEAD><BODY BGCOLOR="white" TEXT="black"> -<CENTER> -<H1>The Language Pec</H1> -<FONT SIZE="4"><I>BNF Converter</I></FONT><BR> -</CENTER> - -<P> -This document was automatically generated by the <I>BNF-Converter</I>. 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). -</P> - -<H2>The lexical structure of Pec</H2> - -<H3>Literals</H3> - -<P> -String literals <I>String</I> have the form -<CODE>"</CODE><I>x</I><CODE>"</CODE>, where <I>x</I> is any sequence of any characters -except <CODE>"</CODE> unless preceded by <CODE>\</CODE>. -</P> -<P> -Character literals <I>Char</I> have the form -<CODE>'</CODE><I>c</I><CODE>'</CODE>, where <I>c</I> is any single character. -</P> -<P> -Frac literals are recognized by the regular expression -<CODE>`</CODE>'-'? digit+ '.' digit+ ('e' '-'? digit+)?<CODE>`</CODE> -</P> -<P> -Uident literals are recognized by the regular expression -<CODE>`</CODE>upper (letter | digit | '_')*<CODE>`</CODE> -</P> -<P> -Lident literals are recognized by the regular expression -<CODE>`</CODE>(lower | '_') (letter | digit | '_')*<CODE>`</CODE> -</P> -<P> -USym literals are recognized by the regular expression -<CODE>`</CODE>('!' | '#' | '$' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '\' | '^' | '|' | '~')+<CODE>`</CODE> -</P> -<P> -Number literals are recognized by the regular expression -<CODE>`</CODE>'-'? digit+<CODE>`</CODE> -</P> -<P> -Count literals are recognized by the regular expression -<CODE>`</CODE>'#' digit+<CODE>`</CODE> -</P> - -<H3>Reserved words and symbols</H3> - -<P> -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. -</P> -<P> -The reserved words used in Pec are the following: -</P> - -<TABLE ALIGN="center" CELLPADDING="4"> -<TR> -<TD><CODE>Array</CODE></TD> -<TD><CODE>all</CODE></TD> -<TD><CODE>as</CODE></TD> -<TD><CODE>branch</CODE></TD> -</TR> -<TR> -<TD><CODE>case</CODE></TD> -<TD><CODE>do</CODE></TD> -<TD><CODE>exports</CODE></TD> -<TD><CODE>extern</CODE></TD> -</TR> -<TR> -<TD><CODE>import</CODE></TD> -<TD><CODE>in</CODE></TD> -<TD><CODE>let</CODE></TD> -<TD><CODE>module</CODE></TD> -</TR> -<TR> -<TD><CODE>of</CODE></TD> -<TD><CODE>type</CODE></TD> -<TD><CODE>where</CODE></TD> -</TR> -</TABLE> - -<P> -The symbols used in Pec are the following: -</P> - -<TABLE ALIGN="center" CELLPADDING="4"> -<TR> -<TD>{</TD> -<TD>}</TD> -<TD>(</TD> -<TD>)</TD> -</TR> -<TR> -<TD>.</TD> -<TD>..</TD> -<TD>::</TD> -<TD>=</TD> -</TR> -<TR> -<TD><-</TD> -<TD>[</TD> -<TD>]</TD> -<TD>@</TD> -</TR> -<TR> -<TD>-></TD> -<TD>|</TD> -<TD>#</TD> -<TD>,</TD> -</TR> -<TR> -<TD>;</TD> -<TD></TD> -<TD></TD> -</TR> -</TABLE> - -<H3>Comments</H3> - -<P> -Single-line comments begin with //.Multiple-line comments are enclosed with /* and */. -</P> - -<H2>The syntactic structure of Pec</H2> - -<P> -Non-terminals are enclosed between < and >. -The symbols -> (production), <B>|</B> (union) -and <B>eps</B> (empty rule) belong to the BNF notation. -All other symbols are terminals. -</P> - -<TABLE ALIGN="center" CELLPADDING="4"> -<TR> -<TD><I>Module</I></TD> -<TD>-></TD> -<TD><CODE>module</CODE> <I>Modid</I> <CODE>exports</CODE> <I>ExportDecl</I> <CODE>where</CODE> <CODE>{</CODE> <I>[TopDecl]</I> <CODE>}</CODE></TD> -</TR> -<TR> -<TD><I>ExportDecl</I></TD> -<TD>-></TD> -<TD><CODE>all</CODE></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>(</CODE> <I>[Export]</I> <CODE>)</CODE></TD> -</TR> -<TR> -<TD><I>Export</I></TD> -<TD>-></TD> -<TD><I>Con</I> <I>Spec</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Var</I></TD> -</TR> -<TR> -<TD><I>Spec</I></TD> -<TD>-></TD> -<TD><B>eps</B></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>(</CODE> <CODE>.</CODE> <CODE>)</CODE></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>(</CODE> <CODE>..</CODE> <CODE>)</CODE></TD> -</TR> -<TR> -<TD><I>TopDecl</I></TD> -<TD>-></TD> -<TD><CODE>import</CODE> <I>Modid</I> <I>AsSpec</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>extern</CODE> <I>ExtNm</I> <I>Var</I> <CODE>::</CODE> <I>Type</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>type</CODE> <I>Con</I> <I>[TyVar]</I> <CODE>=</CODE> <I>TyDecl</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Var</I> <CODE>::</CODE> <I>Type</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Var</I> <CODE>=</CODE> <I>Exp</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Var</I> <I>[Exp0]</I> <CODE>=</CODE> <I>Exp</I></TD> -</TR> -<TR> -<TD><I>AsSpec</I></TD> -<TD>-></TD> -<TD><CODE>as</CODE> <I>Con</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><B>eps</B></TD> -</TR> -<TR> -<TD><I>ExtNm</I></TD> -<TD>-></TD> -<TD><I>String</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><B>eps</B></TD> -</TR> -<TR> -<TD><I>Exp</I></TD> -<TD>-></TD> -<TD><CODE>do</CODE> <CODE>{</CODE> <I>[Exp5]</I> <CODE>}</CODE></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Exp5</I></TD> -</TR> -<TR> -<TD><I>Exp5</I></TD> -<TD>-></TD> -<TD><I>Exp4</I> <CODE>=</CODE> <I>Exp</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>let</CODE> <I>Exp4</I> <CODE>=</CODE> <I>Exp</I> <CODE>in</CODE> <I>Exp</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Exp4</I> <CODE><-</CODE> <I>Exp</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>case</CODE> <I>Exp</I> <CODE>of</CODE> <CODE>{</CODE> <I>[CaseAlt]</I> <CODE>}</CODE></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>branch</CODE> <CODE>of</CODE> <CODE>{</CODE> <I>[BranchAlt]</I> <CODE>}</CODE></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Exp4</I></TD> -</TR> -<TR> -<TD><I>Exp4</I></TD> -<TD>-></TD> -<TD><I>Exp3</I> <I>USym</I> <I>Exp3</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Exp3</I></TD> -</TR> -<TR> -<TD><I>Exp3</I></TD> -<TD>-></TD> -<TD><I>Exp3</I> <I>Exp2</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Exp2</I></TD> -</TR> -<TR> -<TD><I>Exp2</I></TD> -<TD>-></TD> -<TD><I>UnOp</I> <I>Exp1</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Exp1</I></TD> -</TR> -<TR> -<TD><I>Exp1</I></TD> -<TD>-></TD> -<TD><I>Exp1</I> <CODE>[</CODE> <I>Exp</I> <CODE>]</CODE></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Exp1</I> <CODE>.</CODE> <I>Field</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Exp0</I></TD> -</TR> -<TR> -<TD><I>Exp0</I></TD> -<TD>-></TD> -<TD><CODE>Array</CODE> <CODE>[</CODE> <I>[Exp]</I> <CODE>]</CODE></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>{</CODE> <I>[FieldD]</I> <CODE>}</CODE></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>(</CODE> <I>[Exp]</I> <CODE>)</CODE></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>(</CODE> <I>Exp</I> <CODE>::</CODE> <I>Type</I> <CODE>)</CODE></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Count</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Var</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Lit</I></TD> -</TR> -<TR> -<TD><I>UnOp</I></TD> -<TD>-></TD> -<TD><CODE>@</CODE></TD> -</TR> -<TR> -<TD><I>CaseAlt</I></TD> -<TD>-></TD> -<TD><I>CasePat</I> <CODE>-></CODE> <I>Exp</I></TD> -</TR> -<TR> -<TD><I>CasePat</I></TD> -<TD>-></TD> -<TD><I>Con</I> <I>Var</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Lit</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Var</I></TD> -</TR> -<TR> -<TD><I>BranchAlt</I></TD> -<TD>-></TD> -<TD><CODE>|</CODE> <I>BranchPat</I> <CODE>-></CODE> <I>Exp</I></TD> -</TR> -<TR> -<TD><I>BranchPat</I></TD> -<TD>-></TD> -<TD><I>Exp4</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><B>eps</B></TD> -</TR> -<TR> -<TD><I>Type</I></TD> -<TD>-></TD> -<TD><I>Type2</I> <CODE>-></CODE> <I>Type</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Type2</I></TD> -</TR> -<TR> -<TD><I>Type2</I></TD> -<TD>-></TD> -<TD><CODE>Array</CODE> <I>Type1</I> <I>Type1</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Con</I> <I>[Type1]</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Type1</I></TD> -</TR> -<TR> -<TD><I>Type1</I></TD> -<TD>-></TD> -<TD><I>Type0</I></TD> -</TR> -<TR> -<TD><I>Type0</I></TD> -<TD>-></TD> -<TD><CODE>(</CODE> <I>[Type]</I> <CODE>)</CODE></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Count</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>TyVar</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Con</I></TD> -</TR> -<TR> -<TD><I>TyDecl</I></TD> -<TD>-></TD> -<TD><CODE>{</CODE> <I>[FieldT]</I> <CODE>}</CODE></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>|</CODE> <I>[ConC]</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Type</I></TD> -</TR> -<TR> -<TD><I>ConC</I></TD> -<TD>-></TD> -<TD><I>Con</I> <I>[Type0]</I></TD> -</TR> -<TR> -<TD><I>FieldT</I></TD> -<TD>-></TD> -<TD><I>Field</I> <CODE>::</CODE> <I>Type</I></TD> -</TR> -<TR> -<TD><I>Lit</I></TD> -<TD>-></TD> -<TD><I>Char</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>String</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Number</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Frac</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Con</I></TD> -</TR> -<TR> -<TD><I>FieldD</I></TD> -<TD>-></TD> -<TD><I>Field</I> <CODE>=</CODE> <I>Exp</I></TD> -</TR> -<TR> -<TD><I>Var</I></TD> -<TD>-></TD> -<TD><I>Lident</I></TD> -</TR> -<TR> -<TD><I>Con</I></TD> -<TD>-></TD> -<TD><I>Uident</I></TD> -</TR> -<TR> -<TD><I>Modid</I></TD> -<TD>-></TD> -<TD><I>Uident</I></TD> -</TR> -<TR> -<TD><I>Field</I></TD> -<TD>-></TD> -<TD><I>Lident</I></TD> -</TR> -<TR> -<TD><I>TyVar</I></TD> -<TD>-></TD> -<TD><I>Lident</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><CODE>#</CODE> <I>Lident</I></TD> -</TR> -<TR> -<TD><I>[Exp]</I></TD> -<TD>-></TD> -<TD><B>eps</B></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Exp</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Exp</I> <CODE>,</CODE> <I>[Exp]</I></TD> -</TR> -<TR> -<TD><I>[FieldT]</I></TD> -<TD>-></TD> -<TD><B>eps</B></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>FieldT</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>FieldT</I> <CODE>,</CODE> <I>[FieldT]</I></TD> -</TR> -<TR> -<TD><I>[TyVar]</I></TD> -<TD>-></TD> -<TD><B>eps</B></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>TyVar</I> <I>[TyVar]</I></TD> -</TR> -<TR> -<TD><I>[Type]</I></TD> -<TD>-></TD> -<TD><B>eps</B></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Type</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Type</I> <CODE>,</CODE> <I>[Type]</I></TD> -</TR> -<TR> -<TD><I>[Export]</I></TD> -<TD>-></TD> -<TD><B>eps</B></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Export</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Export</I> <CODE>,</CODE> <I>[Export]</I></TD> -</TR> -<TR> -<TD><I>[Type0]</I></TD> -<TD>-></TD> -<TD><B>eps</B></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Type0</I> <I>[Type0]</I></TD> -</TR> -<TR> -<TD><I>[ConC]</I></TD> -<TD>-></TD> -<TD><I>ConC</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>ConC</I> <CODE>|</CODE> <I>[ConC]</I></TD> -</TR> -<TR> -<TD><I>[Exp0]</I></TD> -<TD>-></TD> -<TD><I>Exp0</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Exp0</I> <I>[Exp0]</I></TD> -</TR> -<TR> -<TD><I>[FieldD]</I></TD> -<TD>-></TD> -<TD><I>FieldD</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>FieldD</I> <CODE>,</CODE> <I>[FieldD]</I></TD> -</TR> -<TR> -<TD><I>[Type1]</I></TD> -<TD>-></TD> -<TD><I>Type1</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Type1</I> <I>[Type1]</I></TD> -</TR> -<TR> -<TD><I>[TopDecl]</I></TD> -<TD>-></TD> -<TD><B>eps</B></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>TopDecl</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>TopDecl</I> <CODE>;</CODE> <I>[TopDecl]</I></TD> -</TR> -<TR> -<TD><I>[CaseAlt]</I></TD> -<TD>-></TD> -<TD><I>CaseAlt</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>CaseAlt</I> <CODE>;</CODE> <I>[CaseAlt]</I></TD> -</TR> -<TR> -<TD><I>[BranchAlt]</I></TD> -<TD>-></TD> -<TD><I>BranchAlt</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>BranchAlt</I> <CODE>;</CODE> <I>[BranchAlt]</I></TD> -</TR> -<TR> -<TD><I>[Exp5]</I></TD> -<TD>-></TD> -<TD><I>Exp5</I></TD> -</TR> -<TR> -<TD></TD> -<TD ALIGN="center"><B>|</B></TD> -<TD><I>Exp5</I> <CODE>;</CODE> <I>[Exp5]</I></TD> -</TR> -</TABLE> - -<!-- html code generated by txt2tags 2.6 (http://txt2tags.org) --> -<!-- cmdline: txt2tags -t html Doc.txt --> -</BODY></HTML>
− Language/Pec/ErrM.hs
@@ -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
− Language/Pec/Layout.hs
@@ -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-
− Language/Pec/Lex.x
@@ -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-}
− Language/Pec/Par.hs
@@ -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 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}-{-# 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.
+ Language/Pec/Par.y view
@@ -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}
− Language/Pec/Print.hs
@@ -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<i then parenth else id---instance Print Integer where- prt _ x = doc (shows x)---instance Print Double where- prt _ x = doc (shows x)----instance Print Frac where- prt _ (Frac i) = doc (showString ( i))---instance Print Uident where- prt _ (Uident i) = doc (showString ( i))---instance Print Lident where- prt _ (Lident i) = doc (showString ( i))---instance Print USym where- prt _ (USym i) = doc (showString ( i))---instance Print Number where- prt _ (Number i) = doc (showString ( i))---instance Print Count where- prt _ (Count i) = doc (showString ( i))----instance Print Module where- prt i e = case e of- Module modid exportdecl topdecls -> 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])--
+ Language/Pir/Abs.hs view
@@ -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
− Main.hs
@@ -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 ++ ")"
Makefile view
@@ -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
+ MkPec.hs view
@@ -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
+ Pds.grm view
@@ -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
− Pec.cf
@@ -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 ";";
+ Pec.grm view
@@ -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
Pec/Base.hs view
@@ -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"
+ Pec/C.hs view
@@ -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
+ Pec/Desugar.hs view
@@ -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
+ Pec/HUtil.hs view
@@ -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
+ Pec/IUtil.hs view
@@ -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 .. ]
+ Pec/LLVM.hs view
@@ -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))
− Pec/Makefile
@@ -1,2 +0,0 @@-clean : - rm -f *~ *.hi *.o
+ Pec/PUtil.hs view
@@ -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
+ Pir.grm view
@@ -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
README view
@@ -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
Setup.hs view
@@ -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
THANKS view
@@ -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!+
TODO view
@@ -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
− dist/build/pec/pec-tmp/Language/Pec/Lex.hs
@@ -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 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}-{-# 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
+ lib/Data/Array.pec view
@@ -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)
+ lib/Data/Deque.pec view
@@ -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
+ lib/Data/Queue.pec view
@@ -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)
+ lib/Data/Stack.pec view
@@ -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)
+ lib/Data/StrBuf.pec view
@@ -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))
lib/Prelude.pec view
@@ -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
− lib/Stack.pec
@@ -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))
− lib/StrBuf.pec
@@ -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_))
pec.cabal view
@@ -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 <brettletner@gmail.com> - -Maintainer: Brett Letner <brettletner@gmail.com> - -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 <brettletner@gmail.com>++Maintainer: Brett Letner <brettletner@gmail.com>++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, .
+ src/Pec.hs view
@@ -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
+ src/PecGen.hs view
@@ -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
+ src/PecGenCnt.hs view
@@ -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"
− test_cases/Makefile
@@ -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
test_cases/TestArray.pec view
@@ -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+*/
test_cases/TestLoad.pec view
@@ -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
test_cases/TestPrims.pec view
@@ -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
test_cases/TestStack.pec view
@@ -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
test_cases/TestStrBuf.pec view
@@ -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"
test_cases/TestTuple.pec view
@@ -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
test_cases/TestVariant.pec view
@@ -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 <constr>_unwrap. Also <constr>_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"