diff --git a/DESIGN b/DESIGN new file mode 100644 --- /dev/null +++ b/DESIGN @@ -0,0 +1,103 @@ +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. diff --git a/FAQ b/FAQ new file mode 100644 --- /dev/null +++ b/FAQ @@ -0,0 +1,82 @@ +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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +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. diff --git a/Language/Pec/Abs.hs b/Language/Pec/Abs.hs new file mode 100644 --- /dev/null +++ b/Language/Pec/Abs.hs @@ -0,0 +1,151 @@ +module Language.Pec.Abs where + +-- 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) + diff --git a/Language/Pec/Doc.html b/Language/Pec/Doc.html new file mode 100644 --- /dev/null +++ b/Language/Pec/Doc.html @@ -0,0 +1,695 @@ + + + + +The Language Pec + +
+

The Language Pec

+BNF Converter
+
+ +

+This document was automatically generated by the BNF-Converter. It was generated together with the lexer, the parser, and the abstract syntax module, which guarantees that the document matches with the implementation of the language (provided no hand-hacking has taken place). +

+ +

The lexical structure of Pec

+ +

Literals

+ +

+String literals String have the form +"x", where x is any sequence of any characters +except " unless preceded by \. +

+

+Character literals Char have the form +'c', where c is any single character. +

+

+Frac literals are recognized by the regular expression +`'-'? digit+ '.' digit+ ('e' '-'? digit+)?` +

+

+Uident literals are recognized by the regular expression +`upper (letter | digit | '_')*` +

+

+Lident literals are recognized by the regular expression +`(lower | '_') (letter | digit | '_')*` +

+

+USym literals are recognized by the regular expression +`('!' | '#' | '$' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '\' | '^' | '|' | '~')+` +

+

+Number literals are recognized by the regular expression +`'-'? digit+` +

+

+Count literals are recognized by the regular expression +`'#' digit+` +

+ +

Reserved words and symbols

+ +

+The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions. +

+

+The reserved words used in Pec are the following: +

+ + + + + + + + + + + + + + + + + + + + + + + + + +
Arrayallasbranch
casedoexportsextern
importinletmodule
oftypewhere
+ +

+The symbols used in Pec are the following: +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
{}()
...::=
<-[]@
->|#,
;
+ +

Comments

+ +

+Single-line comments begin with //.Multiple-line comments are enclosed with /* and */. +

+ +

The syntactic structure of Pec

+ +

+Non-terminals are enclosed between < and >. +The symbols -> (production), | (union) +and eps (empty rule) belong to the BNF notation. +All other symbols are terminals. +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Module->module Modid exports ExportDecl where { [TopDecl] }
ExportDecl->all
|( [Export] )
Export->Con Spec
|Var
Spec->eps
|( . )
|( .. )
TopDecl->import Modid AsSpec
|extern ExtNm Var :: Type
|type Con [TyVar] = TyDecl
|Var :: Type
|Var = Exp
|Var [Exp0] = Exp
AsSpec->as Con
|eps
ExtNm->String
|eps
Exp->do { [Exp5] }
|Exp5
Exp5->Exp4 = Exp
|let Exp4 = Exp in Exp
|Exp4 <- Exp
|case Exp of { [CaseAlt] }
|branch of { [BranchAlt] }
|Exp4
Exp4->Exp3 USym Exp3
|Exp3
Exp3->Exp3 Exp2
|Exp2
Exp2->UnOp Exp1
|Exp1
Exp1->Exp1 [ Exp ]
|Exp1 . Field
|Exp0
Exp0->Array [ [Exp] ]
|{ [FieldD] }
|( [Exp] )
|( Exp :: Type )
|Count
|Var
|Lit
UnOp->@
CaseAlt->CasePat -> Exp
CasePat->Con Var
|Lit
|Var
BranchAlt->| BranchPat -> Exp
BranchPat->Exp4
|eps
Type->Type2 -> Type
|Type2
Type2->Array Type1 Type1
|Con [Type1]
|Type1
Type1->Type0
Type0->( [Type] )
|Count
|TyVar
|Con
TyDecl->{ [FieldT] }
|| [ConC]
|Type
ConC->Con [Type0]
FieldT->Field :: Type
Lit->Char
|String
|Number
|Frac
|Con
FieldD->Field = Exp
Var->Lident
Con->Uident
Modid->Uident
Field->Lident
TyVar->Lident
|# Lident
[Exp]->eps
|Exp
|Exp , [Exp]
[FieldT]->eps
|FieldT
|FieldT , [FieldT]
[TyVar]->eps
|TyVar [TyVar]
[Type]->eps
|Type
|Type , [Type]
[Export]->eps
|Export
|Export , [Export]
[Type0]->eps
|Type0 [Type0]
[ConC]->ConC
|ConC | [ConC]
[Exp0]->Exp0
|Exp0 [Exp0]
[FieldD]->FieldD
|FieldD , [FieldD]
[Type1]->Type1
|Type1 [Type1]
[TopDecl]->eps
|TopDecl
|TopDecl ; [TopDecl]
[CaseAlt]->CaseAlt
|CaseAlt ; [CaseAlt]
[BranchAlt]->BranchAlt
|BranchAlt ; [BranchAlt]
[Exp5]->Exp5
|Exp5 ; [Exp5]
+ + + + diff --git a/Language/Pec/ErrM.hs b/Language/Pec/ErrM.hs new file mode 100644 --- /dev/null +++ b/Language/Pec/ErrM.hs @@ -0,0 +1,26 @@ +-- BNF Converter: Error Monad +-- Copyright (C) 2004 Author: Aarne Ranta + +-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE. +module Language.Pec.ErrM where + +-- the Error monad: like Maybe type with error msgs + +import Control.Monad (MonadPlus(..), liftM) + +data Err a = Ok a | Bad String + deriving (Read, Show, Eq, Ord) + +instance Monad Err where + return = Ok + fail = Bad + Ok a >>= f = f a + Bad s >>= f = Bad s + +instance Functor Err where + fmap = liftM + +instance MonadPlus Err where + mzero = Bad "Err.mzero" + mplus (Bad _) y = y + mplus x _ = x diff --git a/Language/Pec/Layout.hs b/Language/Pec/Layout.hs new file mode 100644 --- /dev/null +++ b/Language/Pec/Layout.hs @@ -0,0 +1,262 @@ +module Language.Pec.Layout where + +import Language.Pec.Lex + + +import Data.Maybe (isNothing, fromJust) + +-- Generated by the BNF Converter + +-- local parameters + +topLayout = False +layoutWords = ["where","do","of"] +layoutStopWords = [] + +-- layout separators + +layoutOpen = "{" +layoutClose = "}" +layoutSep = ";" + +-- | Replace layout syntax with explicit layout tokens. +resolveLayout :: Bool -- ^ Whether to use top-level layout. + -> [Token] -> [Token] +resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit] + where + -- Do top-level layout if the function parameter and the grammar say so. + tl = tp && topLayout + + res :: Maybe Token -- ^ The previous token, if any. + -> [Block] -- ^ A stack of layout blocks. + -> [Token] -> [Token] + + -- The stack should never be empty. + res _ [] ts = error $ "Layout error: stack empty. Tokens: " ++ show ts + + res _ st (t0:ts) + -- We found an open brace in the input, + -- put an explicit layout block on the stack. + -- This is done even if there was no layout word, + -- to keep opening and closing braces. + | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts + + res _ st (t0:ts) + -- Start a new layout block if the first token is a layout word + | isLayout t0 = + case ts of + -- Explicit layout, just move on. The case above + -- will push an explicit layout block. + t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts + -- at end of file, the start column doesn't matter + _ -> let col = if null ts then column t0 else column (head ts) + -- insert an open brace after the layout word + b:ts' = addToken (nextPos t0) layoutOpen ts + -- save the start column + st' = Implicit col:st + in moveAlong st' [t0,b] ts' + + -- If we encounter a closing brace, exit the first explicit layout block. + | isLayoutClose t0 = + let st' = drop 1 (dropWhile isImplicit st) + in if null st' + then error $ "Layout error: Found " ++ layoutClose ++ " at (" + ++ show (line t0) ++ "," ++ show (column t0) + ++ ") without an explicit layout block." + else moveAlong st' [t0] ts + + -- We are in an implicit layout block + res pt st@(Implicit n:ns) (t0:ts) + + -- End of implicit block by a layout stop word + | isStop t0 = + -- Exit the current block and all implicit blocks + -- more indented than the current token + let (ebs,ns') = span (`moreIndent` column t0) ns + moreIndent (Implicit x) y = x > y + moreIndent Explicit _ = False + -- the number of blocks exited + b = 1 + length ebs + bs = replicate b layoutClose + -- Insert closing braces after the previous token. + (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts) + in moveAlong ns' ts1 ts2 + + -- End of an implicit layout block + | newLine && column t0 < n = + -- Insert a closing brace after the previous token. + let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts) + -- Repeat, with the current block removed from the stack + in moveAlong ns [b] (t0':ts') + + -- Encounted a new line in an implicit layout block. + | newLine && column t0 == n = + -- Insert a semicolon after the previous token. + -- unless we are the beginning of the file, + -- or the previous token is a semicolon or open brace. + if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt) + then moveAlong st [t0] ts + else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts) + in moveAlong st [b,t0'] ts' + where newLine = case pt of + Nothing -> True + Just t -> line t /= line t0 + + -- Nothing to see here, move along. + res _ st (t:ts) = moveAlong st [t] ts + + -- At EOF: skip explicit blocks. + res (Just t) (Explicit:bs) [] | null bs = [] + | otherwise = res (Just t) bs [] + + -- If we are using top-level layout, insert a semicolon after + -- the last token, if there isn't one already + res (Just t) [Implicit n] [] + | isTokenIn [layoutSep] t = [] + | otherwise = addToken (nextPos t) layoutSep [] + + -- At EOF in an implicit, non-top-level block: close the block + res (Just t) (Implicit n:bs) [] = + let c = addToken (nextPos t) layoutClose [] + in moveAlong bs c [] + + -- This should only happen if the input is empty. + res Nothing st [] = [] + + -- | Move on to the next token. + moveAlong :: [Block] -- ^ The layout stack. + -> [Token] -- ^ Any tokens just processed. + -> [Token] -- ^ the rest of the tokens. + -> [Token] + moveAlong st [] ts = error $ "Layout error: moveAlong got [] as old tokens" + moveAlong st ot ts = ot ++ res (Just $ last ot) st ts + +data Block = Implicit Int -- ^ An implicit layout block with its start column. + | Explicit + deriving Show + +type Position = Posn + +-- | Check if s block is implicit. +isImplicit :: Block -> Bool +isImplicit (Implicit _) = True +isImplicit _ = False + +-- | Insert a number of tokens at the begninning of a list of tokens. +addTokens :: Position -- ^ Position of the first new token. + -> [String] -- ^ Token symbols. + -> [Token] -- ^ The rest of the tokens. These will have their + -- positions updated to make room for the new tokens . + -> [Token] +addTokens p ss ts = foldr (addToken p) ts ss + +-- | Insert a new symbol token at the begninning of a list of tokens. +addToken :: Position -- ^ Position of the new token. + -> String -- ^ Symbol in the new token. + -> [Token] -- ^ The rest of the tokens. These will have their + -- positions updated to make room for the new token. + -> [Token] +addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts + +-- | Get the position immediately to the right of the given token. +-- If no token is given, gets the first position in the file. +afterPrev :: Maybe Token -> Position +afterPrev = maybe (Pn 0 1 1) nextPos + +-- | Get the position immediately to the right of the given token. +nextPos :: Token -> Position +nextPos t = Pn (g + s) l (c + s + 1) + where Pn g l c = position t + s = tokenLength t + +-- | Add to the global and column positions of a token. +-- The column position is only changed if the token is on +-- the same line as the given position. +incrGlobal :: Position -- ^ If the token is on the same line + -- as this position, update the column position. + -> Int -- ^ Number of characters to add to the position. + -> Token -> Token +incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) = + if l /= l0 then PT (Pn (g + i) l c) t + else PT (Pn (g + i) l (c + i)) t +incrGlobal _ _ p = error $ "cannot add token at " ++ show p + +-- | Create a symbol token. +sToken :: Position -> String -> Token +sToken p s = PT p (TS s i) + where + i = case s of + "#" -> 1 + "(" -> 2 + ")" -> 3 + "," -> 4 + "->" -> 5 + "." -> 6 + ".." -> 7 + "::" -> 8 + ";" -> 9 + "<-" -> 10 + "=" -> 11 + "@" -> 12 + "Array" -> 13 + "[" -> 14 + "]" -> 15 + "all" -> 16 + "as" -> 17 + "branch" -> 18 + "case" -> 19 + "do" -> 20 + "exports" -> 21 + "extern" -> 22 + "import" -> 23 + "in" -> 24 + "let" -> 25 + "module" -> 26 + "of" -> 27 + "type" -> 28 + "where" -> 29 + "{" -> 30 + "|" -> 31 + "}" -> 32 + _ -> error $ "not a reserved word: " ++ show s + +-- | Get the position of a token. +position :: Token -> Position +position t = case t of + PT p _ -> p + Err p -> p + +-- | Get the line number of a token. +line :: Token -> Int +line t = case position t of Pn _ l _ -> l + +-- | Get the column number of a token. +column :: Token -> Int +column t = case position t of Pn _ _ c -> c + +-- | Check if a token is one of the given symbols. +isTokenIn :: [String] -> Token -> Bool +isTokenIn ts t = case t of + PT _ (TS r _) | elem r ts -> True + _ -> False + +-- | Check if a word is a layout start token. +isLayout :: Token -> Bool +isLayout = isTokenIn layoutWords + +-- | Check if a token is a layout stop token. +isStop :: Token -> Bool +isStop = isTokenIn layoutStopWords + +-- | Check if a token is the layout open token. +isLayoutOpen :: Token -> Bool +isLayoutOpen = isTokenIn [layoutOpen] + +-- | Check if a token is the layout close token. +isLayoutClose :: Token -> Bool +isLayoutClose = isTokenIn [layoutClose] + +-- | Get the number of characters in the token. +tokenLength :: Token -> Int +tokenLength t = length $ prToken t + diff --git a/Language/Pec/Lex.x b/Language/Pec/Lex.x new file mode 100644 --- /dev/null +++ b/Language/Pec/Lex.x @@ -0,0 +1,156 @@ +-- -*- haskell -*- +-- This Alex file was machine-generated by the BNF converter +{ +{-# OPTIONS -fno-warn-incomplete-patterns #-} +module Language.Pec.Lex where + + + +} + + +$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME +$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME +$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME +$d = [0-9] -- digit +$i = [$l $d _ '] -- identifier character +$u = [\0-\255] -- universal: any character + +@rsyms = -- symbols and non-identifier-like reserved words + \{ | \} | \( | \) | \. | \. \. | \: \: | \= | \< \- | \[ | \] | \@ | \- \> | \| | \# | \, | \; + +:- +"//" [.]* ; -- Toss single line comments +"/*" ([$u # \*] | \* [$u # \/])* ("*")+ "/" ; + +$white+ ; +@rsyms { tok (\p s -> PT p (eitherResIdent (TV . share) s)) } +\- ? $d + \. $d + (e \- ? $d +)? { tok (\p s -> PT p (eitherResIdent (T_Frac . share) s)) } +$c ($l | $d | \_)* { tok (\p s -> PT p (eitherResIdent (T_Uident . share) s)) } +($s | \_)($l | $d | \_)* { tok (\p s -> PT p (eitherResIdent (T_Lident . share) s)) } +(\! | \# | \$ | \% | \& | \* | \+ | \- | \. | \/ | \: | \< | \= | \> | \? | \@ | \\ | \^ | \| | \~)+ { tok (\p s -> PT p (eitherResIdent (T_USym . share) s)) } +\- ? $d + { tok (\p s -> PT p (eitherResIdent (T_Number . share) s)) } +\# $d + { tok (\p s -> PT p (eitherResIdent (T_Count . share) s)) } + +$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) } +\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) } +\' ($u # [\' \\] | \\ [\\ \' n t]) \' { tok (\p s -> PT p (TC $ share s)) } + + + +{ + +tok f p s = f p s + +share :: String -> String +share = id + +data Tok = + TS !String !Int -- reserved words and symbols + | TL !String -- string literals + | TI !String -- integer literals + | TV !String -- identifiers + | TD !String -- double precision float literals + | TC !String -- character literals + | T_Frac !String + | T_Uident !String + | T_Lident !String + | T_USym !String + | T_Number !String + | T_Count !String + + deriving (Eq,Show,Ord) + +data Token = + PT Posn Tok + | Err Posn + deriving (Eq,Show,Ord) + +tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l +tokenPos (Err (Pn _ l _) :_) = "line " ++ show l +tokenPos _ = "end of file" + +posLineCol (Pn _ l c) = (l,c) +mkPosToken t@(PT p _) = (posLineCol p, prToken t) + +prToken t = case t of + PT _ (TS s _) -> s + PT _ (TL s) -> s + PT _ (TI s) -> s + PT _ (TV s) -> s + PT _ (TD s) -> s + PT _ (TC s) -> s + PT _ (T_Frac s) -> s + PT _ (T_Uident s) -> s + PT _ (T_Lident s) -> s + PT _ (T_USym s) -> s + PT _ (T_Number s) -> s + PT _ (T_Count s) -> s + + +data BTree = N | B String Tok BTree BTree deriving (Show) + +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = treeFind resWords + where + treeFind N = tv s + treeFind (B a t left right) | s < a = treeFind left + | s > a = treeFind right + | s == a = t + +resWords = b "as" 17 (b ";" 9 (b "->" 5 (b ")" 3 (b "(" 2 (b "#" 1 N N) N) (b "," 4 N N)) (b ".." 7 (b "." 6 N N) (b "::" 8 N N))) (b "Array" 13 (b "=" 11 (b "<-" 10 N N) (b "@" 12 N N)) (b "]" 15 (b "[" 14 N N) (b "all" 16 N N)))) (b "let" 25 (b "exports" 21 (b "case" 19 (b "branch" 18 N N) (b "do" 20 N N)) (b "import" 23 (b "extern" 22 N N) (b "in" 24 N N))) (b "where" 29 (b "of" 27 (b "module" 26 N N) (b "type" 28 N N)) (b "|" 31 (b "{" 30 N N) (b "}" 32 N N)))) + where b s n = let bs = id s + in B bs (TS bs n) + +unescapeInitTail :: String -> String +unescapeInitTail = id . unesc . tail . id where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +------------------------------------------------------------------- +-- Alex wrapper code. +-- A modified "posn" wrapper. +------------------------------------------------------------------- + +data Posn = Pn !Int !Int !Int + deriving (Eq, Show,Ord) + +alexStartPos :: Posn +alexStartPos = Pn 0 1 1 + +alexMove :: Posn -> Char -> Posn +alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 +alexMove (Pn a l c) _ = Pn (a+1) l (c+1) + +type AlexInput = (Posn, -- current position, + Char, -- previous char + String) -- current input string + +tokens :: String -> [Token] +tokens str = go (alexStartPos, '\n', str) + where + go :: AlexInput -> [Token] + go inp@(pos, _, str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError (pos, _, _) -> [Err pos] + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : (go inp') + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p, _, s) = + case s of + [] -> Nothing + (c:s) -> + let p' = alexMove p c + in p' `seq` Just (c, (p', c, s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p, c, s) = c +} diff --git a/Language/Pec/Par.hs b/Language/Pec/Par.hs new file mode 100644 --- /dev/null +++ b/Language/Pec/Par.hs @@ -0,0 +1,3137 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} +module Language.Pec.Par where +import Language.Pec.Abs +import Language.Pec.Lex +import Language.Pec.ErrM + +-- parser produced by Happy Version 1.18.6 + +data HappyAbsSyn + = HappyTerminal (Token) + | HappyErrorToken Int + | HappyAbsSyn4 (String) + | HappyAbsSyn5 (Char) + | HappyAbsSyn6 (Frac) + | HappyAbsSyn7 (Uident) + | HappyAbsSyn8 (Lident) + | HappyAbsSyn9 (USym) + | HappyAbsSyn10 (Number) + | HappyAbsSyn11 (Count) + | HappyAbsSyn12 (Module) + | HappyAbsSyn13 (ExportDecl) + | HappyAbsSyn14 (Export) + | HappyAbsSyn15 (Spec) + | HappyAbsSyn16 (TopDecl) + | HappyAbsSyn17 (AsSpec) + | HappyAbsSyn18 (ExtNm) + | HappyAbsSyn19 (Exp) + | HappyAbsSyn26 (UnOp) + | HappyAbsSyn27 (CaseAlt) + | HappyAbsSyn28 (CasePat) + | HappyAbsSyn29 (BranchAlt) + | HappyAbsSyn30 (BranchPat) + | HappyAbsSyn31 (Type) + | HappyAbsSyn35 (TyDecl) + | HappyAbsSyn36 (ConC) + | HappyAbsSyn37 (FieldT) + | HappyAbsSyn38 (Lit) + | HappyAbsSyn39 (FieldD) + | HappyAbsSyn40 (Var) + | HappyAbsSyn41 (Con) + | HappyAbsSyn42 (Modid) + | HappyAbsSyn43 (Field) + | HappyAbsSyn44 (TyVar) + | HappyAbsSyn45 ([Exp]) + | HappyAbsSyn46 ([FieldT]) + | HappyAbsSyn47 ([TyVar]) + | HappyAbsSyn48 ([Type]) + | HappyAbsSyn49 ([Export]) + | HappyAbsSyn51 ([ConC]) + | HappyAbsSyn53 ([FieldD]) + | HappyAbsSyn55 ([TopDecl]) + | HappyAbsSyn56 ([CaseAlt]) + | HappyAbsSyn57 ([BranchAlt]) + +{- to allow type-synonyms as our monads (likely + - with explicitly-specified bind and return) + - in Haskell98, it seems that with + - /type M a = .../, then /(HappyReduction M)/ + - is not allowed. But Happy is a + - code-generator that can just substitute it. +type HappyReduction m = + Int + -> (Token) + -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn) + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> m HappyAbsSyn +-} + +action_0, + action_1, + action_2, + action_3, + action_4, + action_5, + action_6, + action_7, + action_8, + action_9, + action_10, + action_11, + action_12, + action_13, + action_14, + action_15, + action_16, + action_17, + action_18, + action_19, + action_20, + action_21, + action_22, + action_23, + action_24, + action_25, + action_26, + action_27, + action_28, + action_29, + action_30, + action_31, + action_32, + action_33, + action_34, + action_35, + action_36, + action_37, + action_38, + action_39, + action_40, + action_41, + action_42, + action_43, + action_44, + action_45, + action_46, + action_47, + action_48, + action_49, + action_50, + action_51, + action_52, + action_53, + action_54, + action_55, + action_56, + action_57, + action_58, + action_59, + action_60, + action_61, + action_62, + action_63, + action_64, + action_65, + action_66, + action_67, + action_68, + action_69, + action_70, + action_71, + action_72, + action_73, + action_74, + action_75, + action_76, + action_77, + action_78, + action_79, + action_80, + action_81, + action_82, + action_83, + action_84, + action_85, + action_86, + action_87, + action_88, + action_89, + action_90, + action_91, + action_92, + action_93, + action_94, + action_95, + action_96, + action_97, + action_98, + action_99, + action_100, + action_101, + action_102, + action_103, + action_104, + action_105, + action_106, + action_107, + action_108, + action_109, + action_110, + action_111, + action_112, + action_113, + action_114, + action_115, + action_116, + action_117, + action_118, + action_119, + action_120, + action_121, + action_122, + action_123, + action_124, + action_125, + action_126, + action_127, + action_128, + action_129, + action_130, + action_131, + action_132, + action_133, + action_134, + action_135, + action_136, + action_137, + action_138, + action_139, + action_140, + action_141, + action_142, + action_143, + action_144, + action_145, + action_146, + action_147, + action_148, + action_149, + action_150, + action_151, + action_152, + action_153, + action_154, + action_155, + action_156, + action_157, + action_158, + action_159, + action_160, + action_161, + action_162, + action_163, + action_164, + action_165, + action_166, + action_167, + action_168, + action_169, + action_170, + action_171, + action_172, + action_173, + action_174, + action_175, + action_176, + action_177, + action_178, + action_179, + action_180, + action_181, + action_182, + action_183, + action_184, + action_185, + action_186, + action_187, + action_188, + action_189, + action_190, + action_191, + action_192, + action_193, + action_194, + action_195, + action_196, + action_197, + action_198, + action_199, + action_200, + action_201, + action_202, + action_203 :: () => Int -> ({-HappyReduction (Err) = -} + Int + -> (Token) + -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> (Err) HappyAbsSyn) + +happyReduce_1, + happyReduce_2, + happyReduce_3, + happyReduce_4, + happyReduce_5, + happyReduce_6, + happyReduce_7, + happyReduce_8, + happyReduce_9, + happyReduce_10, + happyReduce_11, + happyReduce_12, + happyReduce_13, + happyReduce_14, + happyReduce_15, + happyReduce_16, + happyReduce_17, + happyReduce_18, + happyReduce_19, + happyReduce_20, + happyReduce_21, + happyReduce_22, + happyReduce_23, + happyReduce_24, + happyReduce_25, + happyReduce_26, + happyReduce_27, + happyReduce_28, + happyReduce_29, + happyReduce_30, + happyReduce_31, + happyReduce_32, + happyReduce_33, + happyReduce_34, + happyReduce_35, + happyReduce_36, + happyReduce_37, + happyReduce_38, + happyReduce_39, + happyReduce_40, + happyReduce_41, + happyReduce_42, + happyReduce_43, + happyReduce_44, + happyReduce_45, + happyReduce_46, + happyReduce_47, + happyReduce_48, + happyReduce_49, + happyReduce_50, + happyReduce_51, + happyReduce_52, + happyReduce_53, + happyReduce_54, + happyReduce_55, + happyReduce_56, + happyReduce_57, + happyReduce_58, + happyReduce_59, + happyReduce_60, + happyReduce_61, + happyReduce_62, + happyReduce_63, + happyReduce_64, + happyReduce_65, + happyReduce_66, + happyReduce_67, + happyReduce_68, + happyReduce_69, + happyReduce_70, + happyReduce_71, + happyReduce_72, + happyReduce_73, + happyReduce_74, + happyReduce_75, + happyReduce_76, + happyReduce_77, + happyReduce_78, + happyReduce_79, + happyReduce_80, + happyReduce_81, + happyReduce_82, + happyReduce_83, + happyReduce_84, + happyReduce_85, + happyReduce_86, + happyReduce_87, + happyReduce_88, + happyReduce_89, + happyReduce_90, + happyReduce_91, + happyReduce_92, + happyReduce_93, + happyReduce_94, + happyReduce_95, + happyReduce_96, + happyReduce_97, + happyReduce_98, + happyReduce_99, + happyReduce_100, + happyReduce_101, + happyReduce_102, + happyReduce_103, + happyReduce_104, + happyReduce_105, + happyReduce_106, + happyReduce_107, + happyReduce_108, + happyReduce_109, + happyReduce_110, + happyReduce_111, + happyReduce_112, + happyReduce_113, + happyReduce_114, + happyReduce_115, + happyReduce_116, + happyReduce_117, + happyReduce_118 :: () => ({-HappyReduction (Err) = -} + Int + -> (Token) + -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> (Err) HappyAbsSyn) + +action_0 (84) = happyShift action_4 +action_0 (12) = happyGoto action_3 +action_0 _ = happyFail + +action_1 (91) = happyShift action_2 +action_1 _ = happyFail + +action_2 _ = happyReduce_1 + +action_3 (100) = happyAccept +action_3 _ = happyFail + +action_4 (94) = happyShift action_7 +action_4 (7) = happyGoto action_5 +action_4 (42) = happyGoto action_6 +action_4 _ = happyFail + +action_5 _ = happyReduce_82 + +action_6 (79) = happyShift action_8 +action_6 _ = happyFail + +action_7 _ = happyReduce_4 + +action_8 (60) = happyShift action_10 +action_8 (74) = happyShift action_11 +action_8 (13) = happyGoto action_9 +action_8 _ = happyFail + +action_9 (87) = happyShift action_19 +action_9 _ = happyFail + +action_10 (94) = happyShift action_7 +action_10 (95) = happyShift action_18 +action_10 (7) = happyGoto action_12 +action_10 (8) = happyGoto action_13 +action_10 (14) = happyGoto action_14 +action_10 (40) = happyGoto action_15 +action_10 (41) = happyGoto action_16 +action_10 (49) = happyGoto action_17 +action_10 _ = happyReduce_97 + +action_11 _ = happyReduce_10 + +action_12 _ = happyReduce_81 + +action_13 _ = happyReduce_80 + +action_14 (62) = happyShift action_24 +action_14 _ = happyReduce_98 + +action_15 _ = happyReduce_13 + +action_16 (60) = happyShift action_23 +action_16 (15) = happyGoto action_22 +action_16 _ = happyReduce_14 + +action_17 (61) = happyShift action_21 +action_17 _ = happyFail + +action_18 _ = happyReduce_5 + +action_19 (88) = happyShift action_20 +action_19 _ = happyFail + +action_20 (80) = happyShift action_31 +action_20 (81) = happyShift action_32 +action_20 (86) = happyShift action_33 +action_20 (95) = happyShift action_18 +action_20 (8) = happyGoto action_13 +action_20 (16) = happyGoto action_28 +action_20 (40) = happyGoto action_29 +action_20 (55) = happyGoto action_30 +action_20 _ = happyReduce_110 + +action_21 _ = happyReduce_11 + +action_22 _ = happyReduce_12 + +action_23 (64) = happyShift action_26 +action_23 (65) = happyShift action_27 +action_23 _ = happyFail + +action_24 (94) = happyShift action_7 +action_24 (95) = happyShift action_18 +action_24 (7) = happyGoto action_12 +action_24 (8) = happyGoto action_13 +action_24 (14) = happyGoto action_14 +action_24 (40) = happyGoto action_15 +action_24 (41) = happyGoto action_16 +action_24 (49) = happyGoto action_25 +action_24 _ = happyReduce_97 + +action_25 _ = happyReduce_99 + +action_26 (61) = happyShift action_60 +action_26 _ = happyFail + +action_27 (61) = happyShift action_59 +action_27 _ = happyFail + +action_28 (67) = happyShift action_58 +action_28 _ = happyReduce_111 + +action_29 (60) = happyShift action_49 +action_29 (66) = happyShift action_50 +action_29 (69) = happyShift action_51 +action_29 (71) = happyShift action_52 +action_29 (88) = happyShift action_53 +action_29 (91) = happyShift action_2 +action_29 (92) = happyShift action_54 +action_29 (93) = happyShift action_55 +action_29 (94) = happyShift action_7 +action_29 (95) = happyShift action_18 +action_29 (97) = happyShift action_56 +action_29 (98) = happyShift action_57 +action_29 (4) = happyGoto action_39 +action_29 (5) = happyGoto action_40 +action_29 (6) = happyGoto action_41 +action_29 (7) = happyGoto action_12 +action_29 (8) = happyGoto action_13 +action_29 (10) = happyGoto action_42 +action_29 (11) = happyGoto action_43 +action_29 (25) = happyGoto action_44 +action_29 (38) = happyGoto action_45 +action_29 (40) = happyGoto action_46 +action_29 (41) = happyGoto action_47 +action_29 (52) = happyGoto action_48 +action_29 _ = happyFail + +action_30 (90) = happyShift action_38 +action_30 _ = happyFail + +action_31 (91) = happyShift action_2 +action_31 (4) = happyGoto action_36 +action_31 (18) = happyGoto action_37 +action_31 _ = happyReduce_26 + +action_32 (94) = happyShift action_7 +action_32 (7) = happyGoto action_5 +action_32 (42) = happyGoto action_35 +action_32 _ = happyFail + +action_33 (94) = happyShift action_7 +action_33 (7) = happyGoto action_12 +action_33 (41) = happyGoto action_34 +action_33 _ = happyFail + +action_34 (47) = happyGoto action_98 +action_34 _ = happyReduce_92 + +action_35 (75) = happyShift action_97 +action_35 (17) = happyGoto action_96 +action_35 _ = happyReduce_24 + +action_36 _ = happyReduce_25 + +action_37 (95) = happyShift action_18 +action_37 (8) = happyGoto action_13 +action_37 (40) = happyGoto action_95 +action_37 _ = happyFail + +action_38 _ = happyReduce_9 + +action_39 _ = happyReduce_75 + +action_40 _ = happyReduce_74 + +action_41 _ = happyReduce_77 + +action_42 _ = happyReduce_76 + +action_43 _ = happyReduce_48 + +action_44 (60) = happyShift action_49 +action_44 (71) = happyShift action_52 +action_44 (88) = happyShift action_53 +action_44 (91) = happyShift action_2 +action_44 (92) = happyShift action_54 +action_44 (93) = happyShift action_55 +action_44 (94) = happyShift action_7 +action_44 (95) = happyShift action_18 +action_44 (97) = happyShift action_56 +action_44 (98) = happyShift action_57 +action_44 (4) = happyGoto action_39 +action_44 (5) = happyGoto action_40 +action_44 (6) = happyGoto action_41 +action_44 (7) = happyGoto action_12 +action_44 (8) = happyGoto action_13 +action_44 (10) = happyGoto action_42 +action_44 (11) = happyGoto action_43 +action_44 (25) = happyGoto action_44 +action_44 (38) = happyGoto action_45 +action_44 (40) = happyGoto action_46 +action_44 (41) = happyGoto action_47 +action_44 (52) = happyGoto action_94 +action_44 _ = happyReduce_104 + +action_45 _ = happyReduce_50 + +action_46 _ = happyReduce_49 + +action_47 _ = happyReduce_78 + +action_48 (69) = happyShift action_93 +action_48 _ = happyFail + +action_49 (60) = happyShift action_49 +action_49 (70) = happyShift action_75 +action_49 (71) = happyShift action_52 +action_49 (76) = happyShift action_76 +action_49 (77) = happyShift action_77 +action_49 (78) = happyShift action_78 +action_49 (83) = happyShift action_79 +action_49 (88) = happyShift action_53 +action_49 (91) = happyShift action_2 +action_49 (92) = happyShift action_54 +action_49 (93) = happyShift action_55 +action_49 (94) = happyShift action_7 +action_49 (95) = happyShift action_18 +action_49 (97) = happyShift action_56 +action_49 (98) = happyShift action_57 +action_49 (4) = happyGoto action_39 +action_49 (5) = happyGoto action_40 +action_49 (6) = happyGoto action_41 +action_49 (7) = happyGoto action_12 +action_49 (8) = happyGoto action_13 +action_49 (10) = happyGoto action_42 +action_49 (11) = happyGoto action_43 +action_49 (19) = happyGoto action_91 +action_49 (20) = happyGoto action_68 +action_49 (21) = happyGoto action_69 +action_49 (22) = happyGoto action_70 +action_49 (23) = happyGoto action_71 +action_49 (24) = happyGoto action_72 +action_49 (25) = happyGoto action_73 +action_49 (26) = happyGoto action_74 +action_49 (38) = happyGoto action_45 +action_49 (40) = happyGoto action_46 +action_49 (41) = happyGoto action_47 +action_49 (45) = happyGoto action_92 +action_49 _ = happyReduce_86 + +action_50 (59) = happyShift action_88 +action_50 (60) = happyShift action_89 +action_50 (71) = happyShift action_90 +action_50 (94) = happyShift action_7 +action_50 (95) = happyShift action_18 +action_50 (98) = happyShift action_57 +action_50 (7) = happyGoto action_12 +action_50 (8) = happyGoto action_80 +action_50 (11) = happyGoto action_81 +action_50 (31) = happyGoto action_82 +action_50 (32) = happyGoto action_83 +action_50 (33) = happyGoto action_84 +action_50 (34) = happyGoto action_85 +action_50 (41) = happyGoto action_86 +action_50 (44) = happyGoto action_87 +action_50 _ = happyFail + +action_51 (60) = happyShift action_49 +action_51 (70) = happyShift action_75 +action_51 (71) = happyShift action_52 +action_51 (76) = happyShift action_76 +action_51 (77) = happyShift action_77 +action_51 (78) = happyShift action_78 +action_51 (83) = happyShift action_79 +action_51 (88) = happyShift action_53 +action_51 (91) = happyShift action_2 +action_51 (92) = happyShift action_54 +action_51 (93) = happyShift action_55 +action_51 (94) = happyShift action_7 +action_51 (95) = happyShift action_18 +action_51 (97) = happyShift action_56 +action_51 (98) = happyShift action_57 +action_51 (4) = happyGoto action_39 +action_51 (5) = happyGoto action_40 +action_51 (6) = happyGoto action_41 +action_51 (7) = happyGoto action_12 +action_51 (8) = happyGoto action_13 +action_51 (10) = happyGoto action_42 +action_51 (11) = happyGoto action_43 +action_51 (19) = happyGoto action_67 +action_51 (20) = happyGoto action_68 +action_51 (21) = happyGoto action_69 +action_51 (22) = happyGoto action_70 +action_51 (23) = happyGoto action_71 +action_51 (24) = happyGoto action_72 +action_51 (25) = happyGoto action_73 +action_51 (26) = happyGoto action_74 +action_51 (38) = happyGoto action_45 +action_51 (40) = happyGoto action_46 +action_51 (41) = happyGoto action_47 +action_51 _ = happyFail + +action_52 (72) = happyShift action_66 +action_52 _ = happyFail + +action_53 (95) = happyShift action_18 +action_53 (8) = happyGoto action_62 +action_53 (39) = happyGoto action_63 +action_53 (43) = happyGoto action_64 +action_53 (53) = happyGoto action_65 +action_53 _ = happyFail + +action_54 _ = happyReduce_2 + +action_55 _ = happyReduce_3 + +action_56 _ = happyReduce_7 + +action_57 _ = happyReduce_8 + +action_58 (80) = happyShift action_31 +action_58 (81) = happyShift action_32 +action_58 (86) = happyShift action_33 +action_58 (95) = happyShift action_18 +action_58 (8) = happyGoto action_13 +action_58 (16) = happyGoto action_28 +action_58 (40) = happyGoto action_29 +action_58 (55) = happyGoto action_61 +action_58 _ = happyReduce_110 + +action_59 _ = happyReduce_16 + +action_60 _ = happyReduce_15 + +action_61 _ = happyReduce_112 + +action_62 _ = happyReduce_83 + +action_63 (62) = happyShift action_131 +action_63 _ = happyReduce_106 + +action_64 (69) = happyShift action_130 +action_64 _ = happyFail + +action_65 (90) = happyShift action_129 +action_65 _ = happyFail + +action_66 (60) = happyShift action_49 +action_66 (70) = happyShift action_75 +action_66 (71) = happyShift action_52 +action_66 (76) = happyShift action_76 +action_66 (77) = happyShift action_77 +action_66 (78) = happyShift action_78 +action_66 (83) = happyShift action_79 +action_66 (88) = happyShift action_53 +action_66 (91) = happyShift action_2 +action_66 (92) = happyShift action_54 +action_66 (93) = happyShift action_55 +action_66 (94) = happyShift action_7 +action_66 (95) = happyShift action_18 +action_66 (97) = happyShift action_56 +action_66 (98) = happyShift action_57 +action_66 (4) = happyGoto action_39 +action_66 (5) = happyGoto action_40 +action_66 (6) = happyGoto action_41 +action_66 (7) = happyGoto action_12 +action_66 (8) = happyGoto action_13 +action_66 (10) = happyGoto action_42 +action_66 (11) = happyGoto action_43 +action_66 (19) = happyGoto action_127 +action_66 (20) = happyGoto action_68 +action_66 (21) = happyGoto action_69 +action_66 (22) = happyGoto action_70 +action_66 (23) = happyGoto action_71 +action_66 (24) = happyGoto action_72 +action_66 (25) = happyGoto action_73 +action_66 (26) = happyGoto action_74 +action_66 (38) = happyGoto action_45 +action_66 (40) = happyGoto action_46 +action_66 (41) = happyGoto action_47 +action_66 (45) = happyGoto action_128 +action_66 _ = happyReduce_86 + +action_67 _ = happyReduce_21 + +action_68 _ = happyReduce_28 + +action_69 (68) = happyShift action_125 +action_69 (69) = happyShift action_126 +action_69 _ = happyReduce_34 + +action_70 (60) = happyShift action_49 +action_70 (70) = happyShift action_75 +action_70 (71) = happyShift action_52 +action_70 (88) = happyShift action_53 +action_70 (91) = happyShift action_2 +action_70 (92) = happyShift action_54 +action_70 (93) = happyShift action_55 +action_70 (94) = happyShift action_7 +action_70 (95) = happyShift action_18 +action_70 (96) = happyShift action_124 +action_70 (97) = happyShift action_56 +action_70 (98) = happyShift action_57 +action_70 (4) = happyGoto action_39 +action_70 (5) = happyGoto action_40 +action_70 (6) = happyGoto action_41 +action_70 (7) = happyGoto action_12 +action_70 (8) = happyGoto action_13 +action_70 (9) = happyGoto action_122 +action_70 (10) = happyGoto action_42 +action_70 (11) = happyGoto action_43 +action_70 (23) = happyGoto action_123 +action_70 (24) = happyGoto action_72 +action_70 (25) = happyGoto action_73 +action_70 (26) = happyGoto action_74 +action_70 (38) = happyGoto action_45 +action_70 (40) = happyGoto action_46 +action_70 (41) = happyGoto action_47 +action_70 _ = happyReduce_36 + +action_71 _ = happyReduce_38 + +action_72 (64) = happyShift action_120 +action_72 (72) = happyShift action_121 +action_72 _ = happyReduce_40 + +action_73 _ = happyReduce_43 + +action_74 (60) = happyShift action_49 +action_74 (71) = happyShift action_52 +action_74 (88) = happyShift action_53 +action_74 (91) = happyShift action_2 +action_74 (92) = happyShift action_54 +action_74 (93) = happyShift action_55 +action_74 (94) = happyShift action_7 +action_74 (95) = happyShift action_18 +action_74 (97) = happyShift action_56 +action_74 (98) = happyShift action_57 +action_74 (4) = happyGoto action_39 +action_74 (5) = happyGoto action_40 +action_74 (6) = happyGoto action_41 +action_74 (7) = happyGoto action_12 +action_74 (8) = happyGoto action_13 +action_74 (10) = happyGoto action_42 +action_74 (11) = happyGoto action_43 +action_74 (24) = happyGoto action_119 +action_74 (25) = happyGoto action_73 +action_74 (38) = happyGoto action_45 +action_74 (40) = happyGoto action_46 +action_74 (41) = happyGoto action_47 +action_74 _ = happyFail + +action_75 _ = happyReduce_51 + +action_76 (85) = happyShift action_118 +action_76 _ = happyFail + +action_77 (60) = happyShift action_49 +action_77 (70) = happyShift action_75 +action_77 (71) = happyShift action_52 +action_77 (76) = happyShift action_76 +action_77 (77) = happyShift action_77 +action_77 (78) = happyShift action_78 +action_77 (83) = happyShift action_79 +action_77 (88) = happyShift action_53 +action_77 (91) = happyShift action_2 +action_77 (92) = happyShift action_54 +action_77 (93) = happyShift action_55 +action_77 (94) = happyShift action_7 +action_77 (95) = happyShift action_18 +action_77 (97) = happyShift action_56 +action_77 (98) = happyShift action_57 +action_77 (4) = happyGoto action_39 +action_77 (5) = happyGoto action_40 +action_77 (6) = happyGoto action_41 +action_77 (7) = happyGoto action_12 +action_77 (8) = happyGoto action_13 +action_77 (10) = happyGoto action_42 +action_77 (11) = happyGoto action_43 +action_77 (19) = happyGoto action_117 +action_77 (20) = happyGoto action_68 +action_77 (21) = happyGoto action_69 +action_77 (22) = happyGoto action_70 +action_77 (23) = happyGoto action_71 +action_77 (24) = happyGoto action_72 +action_77 (25) = happyGoto action_73 +action_77 (26) = happyGoto action_74 +action_77 (38) = happyGoto action_45 +action_77 (40) = happyGoto action_46 +action_77 (41) = happyGoto action_47 +action_77 _ = happyFail + +action_78 (88) = happyShift action_116 +action_78 _ = happyFail + +action_79 (60) = happyShift action_49 +action_79 (70) = happyShift action_75 +action_79 (71) = happyShift action_52 +action_79 (88) = happyShift action_53 +action_79 (91) = happyShift action_2 +action_79 (92) = happyShift action_54 +action_79 (93) = happyShift action_55 +action_79 (94) = happyShift action_7 +action_79 (95) = happyShift action_18 +action_79 (97) = happyShift action_56 +action_79 (98) = happyShift action_57 +action_79 (4) = happyGoto action_39 +action_79 (5) = happyGoto action_40 +action_79 (6) = happyGoto action_41 +action_79 (7) = happyGoto action_12 +action_79 (8) = happyGoto action_13 +action_79 (10) = happyGoto action_42 +action_79 (11) = happyGoto action_43 +action_79 (21) = happyGoto action_115 +action_79 (22) = happyGoto action_70 +action_79 (23) = happyGoto action_71 +action_79 (24) = happyGoto action_72 +action_79 (25) = happyGoto action_73 +action_79 (26) = happyGoto action_74 +action_79 (38) = happyGoto action_45 +action_79 (40) = happyGoto action_46 +action_79 (41) = happyGoto action_47 +action_79 _ = happyFail + +action_80 _ = happyReduce_84 + +action_81 _ = happyReduce_66 + +action_82 _ = happyReduce_20 + +action_83 (63) = happyShift action_114 +action_83 _ = happyReduce_60 + +action_84 _ = happyReduce_63 + +action_85 _ = happyReduce_64 + +action_86 (59) = happyShift action_88 +action_86 (60) = happyShift action_89 +action_86 (94) = happyShift action_7 +action_86 (95) = happyShift action_18 +action_86 (98) = happyShift action_57 +action_86 (7) = happyGoto action_12 +action_86 (8) = happyGoto action_80 +action_86 (11) = happyGoto action_81 +action_86 (33) = happyGoto action_112 +action_86 (34) = happyGoto action_85 +action_86 (41) = happyGoto action_108 +action_86 (44) = happyGoto action_87 +action_86 (54) = happyGoto action_113 +action_86 _ = happyReduce_68 + +action_87 _ = happyReduce_67 + +action_88 (95) = happyShift action_18 +action_88 (8) = happyGoto action_111 +action_88 _ = happyFail + +action_89 (59) = happyShift action_88 +action_89 (60) = happyShift action_89 +action_89 (71) = happyShift action_90 +action_89 (94) = happyShift action_7 +action_89 (95) = happyShift action_18 +action_89 (98) = happyShift action_57 +action_89 (7) = happyGoto action_12 +action_89 (8) = happyGoto action_80 +action_89 (11) = happyGoto action_81 +action_89 (31) = happyGoto action_109 +action_89 (32) = happyGoto action_83 +action_89 (33) = happyGoto action_84 +action_89 (34) = happyGoto action_85 +action_89 (41) = happyGoto action_86 +action_89 (44) = happyGoto action_87 +action_89 (48) = happyGoto action_110 +action_89 _ = happyReduce_94 + +action_90 (59) = happyShift action_88 +action_90 (60) = happyShift action_89 +action_90 (94) = happyShift action_7 +action_90 (95) = happyShift action_18 +action_90 (98) = happyShift action_57 +action_90 (7) = happyGoto action_12 +action_90 (8) = happyGoto action_80 +action_90 (11) = happyGoto action_81 +action_90 (33) = happyGoto action_107 +action_90 (34) = happyGoto action_85 +action_90 (41) = happyGoto action_108 +action_90 (44) = happyGoto action_87 +action_90 _ = happyFail + +action_91 (62) = happyShift action_105 +action_91 (66) = happyShift action_106 +action_91 _ = happyReduce_87 + +action_92 (61) = happyShift action_104 +action_92 _ = happyFail + +action_93 (60) = happyShift action_49 +action_93 (70) = happyShift action_75 +action_93 (71) = happyShift action_52 +action_93 (76) = happyShift action_76 +action_93 (77) = happyShift action_77 +action_93 (78) = happyShift action_78 +action_93 (83) = happyShift action_79 +action_93 (88) = happyShift action_53 +action_93 (91) = happyShift action_2 +action_93 (92) = happyShift action_54 +action_93 (93) = happyShift action_55 +action_93 (94) = happyShift action_7 +action_93 (95) = happyShift action_18 +action_93 (97) = happyShift action_56 +action_93 (98) = happyShift action_57 +action_93 (4) = happyGoto action_39 +action_93 (5) = happyGoto action_40 +action_93 (6) = happyGoto action_41 +action_93 (7) = happyGoto action_12 +action_93 (8) = happyGoto action_13 +action_93 (10) = happyGoto action_42 +action_93 (11) = happyGoto action_43 +action_93 (19) = happyGoto action_103 +action_93 (20) = happyGoto action_68 +action_93 (21) = happyGoto action_69 +action_93 (22) = happyGoto action_70 +action_93 (23) = happyGoto action_71 +action_93 (24) = happyGoto action_72 +action_93 (25) = happyGoto action_73 +action_93 (26) = happyGoto action_74 +action_93 (38) = happyGoto action_45 +action_93 (40) = happyGoto action_46 +action_93 (41) = happyGoto action_47 +action_93 _ = happyFail + +action_94 _ = happyReduce_105 + +action_95 (66) = happyShift action_102 +action_95 _ = happyFail + +action_96 _ = happyReduce_17 + +action_97 (94) = happyShift action_7 +action_97 (7) = happyGoto action_12 +action_97 (41) = happyGoto action_101 +action_97 _ = happyFail + +action_98 (59) = happyShift action_88 +action_98 (69) = happyShift action_100 +action_98 (95) = happyShift action_18 +action_98 (8) = happyGoto action_80 +action_98 (44) = happyGoto action_99 +action_98 _ = happyFail + +action_99 _ = happyReduce_93 + +action_100 (59) = happyShift action_88 +action_100 (60) = happyShift action_89 +action_100 (71) = happyShift action_90 +action_100 (88) = happyShift action_155 +action_100 (89) = happyShift action_156 +action_100 (94) = happyShift action_7 +action_100 (95) = happyShift action_18 +action_100 (98) = happyShift action_57 +action_100 (7) = happyGoto action_12 +action_100 (8) = happyGoto action_80 +action_100 (11) = happyGoto action_81 +action_100 (31) = happyGoto action_153 +action_100 (32) = happyGoto action_83 +action_100 (33) = happyGoto action_84 +action_100 (34) = happyGoto action_85 +action_100 (35) = happyGoto action_154 +action_100 (41) = happyGoto action_86 +action_100 (44) = happyGoto action_87 +action_100 _ = happyFail + +action_101 _ = happyReduce_23 + +action_102 (59) = happyShift action_88 +action_102 (60) = happyShift action_89 +action_102 (71) = happyShift action_90 +action_102 (94) = happyShift action_7 +action_102 (95) = happyShift action_18 +action_102 (98) = happyShift action_57 +action_102 (7) = happyGoto action_12 +action_102 (8) = happyGoto action_80 +action_102 (11) = happyGoto action_81 +action_102 (31) = happyGoto action_152 +action_102 (32) = happyGoto action_83 +action_102 (33) = happyGoto action_84 +action_102 (34) = happyGoto action_85 +action_102 (41) = happyGoto action_86 +action_102 (44) = happyGoto action_87 +action_102 _ = happyFail + +action_103 _ = happyReduce_22 + +action_104 _ = happyReduce_46 + +action_105 (60) = happyShift action_49 +action_105 (70) = happyShift action_75 +action_105 (71) = happyShift action_52 +action_105 (76) = happyShift action_76 +action_105 (77) = happyShift action_77 +action_105 (78) = happyShift action_78 +action_105 (83) = happyShift action_79 +action_105 (88) = happyShift action_53 +action_105 (91) = happyShift action_2 +action_105 (92) = happyShift action_54 +action_105 (93) = happyShift action_55 +action_105 (94) = happyShift action_7 +action_105 (95) = happyShift action_18 +action_105 (97) = happyShift action_56 +action_105 (98) = happyShift action_57 +action_105 (4) = happyGoto action_39 +action_105 (5) = happyGoto action_40 +action_105 (6) = happyGoto action_41 +action_105 (7) = happyGoto action_12 +action_105 (8) = happyGoto action_13 +action_105 (10) = happyGoto action_42 +action_105 (11) = happyGoto action_43 +action_105 (19) = happyGoto action_127 +action_105 (20) = happyGoto action_68 +action_105 (21) = happyGoto action_69 +action_105 (22) = happyGoto action_70 +action_105 (23) = happyGoto action_71 +action_105 (24) = happyGoto action_72 +action_105 (25) = happyGoto action_73 +action_105 (26) = happyGoto action_74 +action_105 (38) = happyGoto action_45 +action_105 (40) = happyGoto action_46 +action_105 (41) = happyGoto action_47 +action_105 (45) = happyGoto action_151 +action_105 _ = happyReduce_86 + +action_106 (59) = happyShift action_88 +action_106 (60) = happyShift action_89 +action_106 (71) = happyShift action_90 +action_106 (94) = happyShift action_7 +action_106 (95) = happyShift action_18 +action_106 (98) = happyShift action_57 +action_106 (7) = happyGoto action_12 +action_106 (8) = happyGoto action_80 +action_106 (11) = happyGoto action_81 +action_106 (31) = happyGoto action_150 +action_106 (32) = happyGoto action_83 +action_106 (33) = happyGoto action_84 +action_106 (34) = happyGoto action_85 +action_106 (41) = happyGoto action_86 +action_106 (44) = happyGoto action_87 +action_106 _ = happyFail + +action_107 (59) = happyShift action_88 +action_107 (60) = happyShift action_89 +action_107 (94) = happyShift action_7 +action_107 (95) = happyShift action_18 +action_107 (98) = happyShift action_57 +action_107 (7) = happyGoto action_12 +action_107 (8) = happyGoto action_80 +action_107 (11) = happyGoto action_81 +action_107 (33) = happyGoto action_149 +action_107 (34) = happyGoto action_85 +action_107 (41) = happyGoto action_108 +action_107 (44) = happyGoto action_87 +action_107 _ = happyFail + +action_108 _ = happyReduce_68 + +action_109 (62) = happyShift action_148 +action_109 _ = happyReduce_95 + +action_110 (61) = happyShift action_147 +action_110 _ = happyFail + +action_111 _ = happyReduce_85 + +action_112 (59) = happyShift action_88 +action_112 (60) = happyShift action_89 +action_112 (94) = happyShift action_7 +action_112 (95) = happyShift action_18 +action_112 (98) = happyShift action_57 +action_112 (7) = happyGoto action_12 +action_112 (8) = happyGoto action_80 +action_112 (11) = happyGoto action_81 +action_112 (33) = happyGoto action_112 +action_112 (34) = happyGoto action_85 +action_112 (41) = happyGoto action_108 +action_112 (44) = happyGoto action_87 +action_112 (54) = happyGoto action_146 +action_112 _ = happyReduce_108 + +action_113 _ = happyReduce_62 + +action_114 (59) = happyShift action_88 +action_114 (60) = happyShift action_89 +action_114 (71) = happyShift action_90 +action_114 (94) = happyShift action_7 +action_114 (95) = happyShift action_18 +action_114 (98) = happyShift action_57 +action_114 (7) = happyGoto action_12 +action_114 (8) = happyGoto action_80 +action_114 (11) = happyGoto action_81 +action_114 (31) = happyGoto action_145 +action_114 (32) = happyGoto action_83 +action_114 (33) = happyGoto action_84 +action_114 (34) = happyGoto action_85 +action_114 (41) = happyGoto action_86 +action_114 (44) = happyGoto action_87 +action_114 _ = happyFail + +action_115 (69) = happyShift action_144 +action_115 _ = happyFail + +action_116 (60) = happyShift action_49 +action_116 (70) = happyShift action_75 +action_116 (71) = happyShift action_52 +action_116 (76) = happyShift action_76 +action_116 (77) = happyShift action_77 +action_116 (83) = happyShift action_79 +action_116 (88) = happyShift action_53 +action_116 (91) = happyShift action_2 +action_116 (92) = happyShift action_54 +action_116 (93) = happyShift action_55 +action_116 (94) = happyShift action_7 +action_116 (95) = happyShift action_18 +action_116 (97) = happyShift action_56 +action_116 (98) = happyShift action_57 +action_116 (4) = happyGoto action_39 +action_116 (5) = happyGoto action_40 +action_116 (6) = happyGoto action_41 +action_116 (7) = happyGoto action_12 +action_116 (8) = happyGoto action_13 +action_116 (10) = happyGoto action_42 +action_116 (11) = happyGoto action_43 +action_116 (20) = happyGoto action_142 +action_116 (21) = happyGoto action_69 +action_116 (22) = happyGoto action_70 +action_116 (23) = happyGoto action_71 +action_116 (24) = happyGoto action_72 +action_116 (25) = happyGoto action_73 +action_116 (26) = happyGoto action_74 +action_116 (38) = happyGoto action_45 +action_116 (40) = happyGoto action_46 +action_116 (41) = happyGoto action_47 +action_116 (58) = happyGoto action_143 +action_116 _ = happyFail + +action_117 (85) = happyShift action_141 +action_117 _ = happyFail + +action_118 (88) = happyShift action_140 +action_118 _ = happyFail + +action_119 (64) = happyShift action_120 +action_119 (72) = happyShift action_121 +action_119 _ = happyReduce_39 + +action_120 (95) = happyShift action_18 +action_120 (8) = happyGoto action_62 +action_120 (43) = happyGoto action_139 +action_120 _ = happyFail + +action_121 (60) = happyShift action_49 +action_121 (70) = happyShift action_75 +action_121 (71) = happyShift action_52 +action_121 (76) = happyShift action_76 +action_121 (77) = happyShift action_77 +action_121 (78) = happyShift action_78 +action_121 (83) = happyShift action_79 +action_121 (88) = happyShift action_53 +action_121 (91) = happyShift action_2 +action_121 (92) = happyShift action_54 +action_121 (93) = happyShift action_55 +action_121 (94) = happyShift action_7 +action_121 (95) = happyShift action_18 +action_121 (97) = happyShift action_56 +action_121 (98) = happyShift action_57 +action_121 (4) = happyGoto action_39 +action_121 (5) = happyGoto action_40 +action_121 (6) = happyGoto action_41 +action_121 (7) = happyGoto action_12 +action_121 (8) = happyGoto action_13 +action_121 (10) = happyGoto action_42 +action_121 (11) = happyGoto action_43 +action_121 (19) = happyGoto action_138 +action_121 (20) = happyGoto action_68 +action_121 (21) = happyGoto action_69 +action_121 (22) = happyGoto action_70 +action_121 (23) = happyGoto action_71 +action_121 (24) = happyGoto action_72 +action_121 (25) = happyGoto action_73 +action_121 (26) = happyGoto action_74 +action_121 (38) = happyGoto action_45 +action_121 (40) = happyGoto action_46 +action_121 (41) = happyGoto action_47 +action_121 _ = happyFail + +action_122 (60) = happyShift action_49 +action_122 (70) = happyShift action_75 +action_122 (71) = happyShift action_52 +action_122 (88) = happyShift action_53 +action_122 (91) = happyShift action_2 +action_122 (92) = happyShift action_54 +action_122 (93) = happyShift action_55 +action_122 (94) = happyShift action_7 +action_122 (95) = happyShift action_18 +action_122 (97) = happyShift action_56 +action_122 (98) = happyShift action_57 +action_122 (4) = happyGoto action_39 +action_122 (5) = happyGoto action_40 +action_122 (6) = happyGoto action_41 +action_122 (7) = happyGoto action_12 +action_122 (8) = happyGoto action_13 +action_122 (10) = happyGoto action_42 +action_122 (11) = happyGoto action_43 +action_122 (22) = happyGoto action_137 +action_122 (23) = happyGoto action_71 +action_122 (24) = happyGoto action_72 +action_122 (25) = happyGoto action_73 +action_122 (26) = happyGoto action_74 +action_122 (38) = happyGoto action_45 +action_122 (40) = happyGoto action_46 +action_122 (41) = happyGoto action_47 +action_122 _ = happyFail + +action_123 _ = happyReduce_37 + +action_124 _ = happyReduce_6 + +action_125 (60) = happyShift action_49 +action_125 (70) = happyShift action_75 +action_125 (71) = happyShift action_52 +action_125 (76) = happyShift action_76 +action_125 (77) = happyShift action_77 +action_125 (78) = happyShift action_78 +action_125 (83) = happyShift action_79 +action_125 (88) = happyShift action_53 +action_125 (91) = happyShift action_2 +action_125 (92) = happyShift action_54 +action_125 (93) = happyShift action_55 +action_125 (94) = happyShift action_7 +action_125 (95) = happyShift action_18 +action_125 (97) = happyShift action_56 +action_125 (98) = happyShift action_57 +action_125 (4) = happyGoto action_39 +action_125 (5) = happyGoto action_40 +action_125 (6) = happyGoto action_41 +action_125 (7) = happyGoto action_12 +action_125 (8) = happyGoto action_13 +action_125 (10) = happyGoto action_42 +action_125 (11) = happyGoto action_43 +action_125 (19) = happyGoto action_136 +action_125 (20) = happyGoto action_68 +action_125 (21) = happyGoto action_69 +action_125 (22) = happyGoto action_70 +action_125 (23) = happyGoto action_71 +action_125 (24) = happyGoto action_72 +action_125 (25) = happyGoto action_73 +action_125 (26) = happyGoto action_74 +action_125 (38) = happyGoto action_45 +action_125 (40) = happyGoto action_46 +action_125 (41) = happyGoto action_47 +action_125 _ = happyFail + +action_126 (60) = happyShift action_49 +action_126 (70) = happyShift action_75 +action_126 (71) = happyShift action_52 +action_126 (76) = happyShift action_76 +action_126 (77) = happyShift action_77 +action_126 (78) = happyShift action_78 +action_126 (83) = happyShift action_79 +action_126 (88) = happyShift action_53 +action_126 (91) = happyShift action_2 +action_126 (92) = happyShift action_54 +action_126 (93) = happyShift action_55 +action_126 (94) = happyShift action_7 +action_126 (95) = happyShift action_18 +action_126 (97) = happyShift action_56 +action_126 (98) = happyShift action_57 +action_126 (4) = happyGoto action_39 +action_126 (5) = happyGoto action_40 +action_126 (6) = happyGoto action_41 +action_126 (7) = happyGoto action_12 +action_126 (8) = happyGoto action_13 +action_126 (10) = happyGoto action_42 +action_126 (11) = happyGoto action_43 +action_126 (19) = happyGoto action_135 +action_126 (20) = happyGoto action_68 +action_126 (21) = happyGoto action_69 +action_126 (22) = happyGoto action_70 +action_126 (23) = happyGoto action_71 +action_126 (24) = happyGoto action_72 +action_126 (25) = happyGoto action_73 +action_126 (26) = happyGoto action_74 +action_126 (38) = happyGoto action_45 +action_126 (40) = happyGoto action_46 +action_126 (41) = happyGoto action_47 +action_126 _ = happyFail + +action_127 (62) = happyShift action_105 +action_127 _ = happyReduce_87 + +action_128 (73) = happyShift action_134 +action_128 _ = happyFail + +action_129 _ = happyReduce_45 + +action_130 (60) = happyShift action_49 +action_130 (70) = happyShift action_75 +action_130 (71) = happyShift action_52 +action_130 (76) = happyShift action_76 +action_130 (77) = happyShift action_77 +action_130 (78) = happyShift action_78 +action_130 (83) = happyShift action_79 +action_130 (88) = happyShift action_53 +action_130 (91) = happyShift action_2 +action_130 (92) = happyShift action_54 +action_130 (93) = happyShift action_55 +action_130 (94) = happyShift action_7 +action_130 (95) = happyShift action_18 +action_130 (97) = happyShift action_56 +action_130 (98) = happyShift action_57 +action_130 (4) = happyGoto action_39 +action_130 (5) = happyGoto action_40 +action_130 (6) = happyGoto action_41 +action_130 (7) = happyGoto action_12 +action_130 (8) = happyGoto action_13 +action_130 (10) = happyGoto action_42 +action_130 (11) = happyGoto action_43 +action_130 (19) = happyGoto action_133 +action_130 (20) = happyGoto action_68 +action_130 (21) = happyGoto action_69 +action_130 (22) = happyGoto action_70 +action_130 (23) = happyGoto action_71 +action_130 (24) = happyGoto action_72 +action_130 (25) = happyGoto action_73 +action_130 (26) = happyGoto action_74 +action_130 (38) = happyGoto action_45 +action_130 (40) = happyGoto action_46 +action_130 (41) = happyGoto action_47 +action_130 _ = happyFail + +action_131 (95) = happyShift action_18 +action_131 (8) = happyGoto action_62 +action_131 (39) = happyGoto action_63 +action_131 (43) = happyGoto action_64 +action_131 (53) = happyGoto action_132 +action_131 _ = happyFail + +action_132 _ = happyReduce_107 + +action_133 _ = happyReduce_79 + +action_134 _ = happyReduce_44 + +action_135 _ = happyReduce_29 + +action_136 _ = happyReduce_31 + +action_137 (60) = happyShift action_49 +action_137 (70) = happyShift action_75 +action_137 (71) = happyShift action_52 +action_137 (88) = happyShift action_53 +action_137 (91) = happyShift action_2 +action_137 (92) = happyShift action_54 +action_137 (93) = happyShift action_55 +action_137 (94) = happyShift action_7 +action_137 (95) = happyShift action_18 +action_137 (97) = happyShift action_56 +action_137 (98) = happyShift action_57 +action_137 (4) = happyGoto action_39 +action_137 (5) = happyGoto action_40 +action_137 (6) = happyGoto action_41 +action_137 (7) = happyGoto action_12 +action_137 (8) = happyGoto action_13 +action_137 (10) = happyGoto action_42 +action_137 (11) = happyGoto action_43 +action_137 (23) = happyGoto action_123 +action_137 (24) = happyGoto action_72 +action_137 (25) = happyGoto action_73 +action_137 (26) = happyGoto action_74 +action_137 (38) = happyGoto action_45 +action_137 (40) = happyGoto action_46 +action_137 (41) = happyGoto action_47 +action_137 _ = happyReduce_35 + +action_138 (73) = happyShift action_172 +action_138 _ = happyFail + +action_139 _ = happyReduce_42 + +action_140 (89) = happyShift action_171 +action_140 (29) = happyGoto action_169 +action_140 (57) = happyGoto action_170 +action_140 _ = happyFail + +action_141 (88) = happyShift action_168 +action_141 _ = happyFail + +action_142 (67) = happyShift action_167 +action_142 _ = happyReduce_117 + +action_143 (90) = happyShift action_166 +action_143 _ = happyFail + +action_144 (60) = happyShift action_49 +action_144 (70) = happyShift action_75 +action_144 (71) = happyShift action_52 +action_144 (76) = happyShift action_76 +action_144 (77) = happyShift action_77 +action_144 (78) = happyShift action_78 +action_144 (83) = happyShift action_79 +action_144 (88) = happyShift action_53 +action_144 (91) = happyShift action_2 +action_144 (92) = happyShift action_54 +action_144 (93) = happyShift action_55 +action_144 (94) = happyShift action_7 +action_144 (95) = happyShift action_18 +action_144 (97) = happyShift action_56 +action_144 (98) = happyShift action_57 +action_144 (4) = happyGoto action_39 +action_144 (5) = happyGoto action_40 +action_144 (6) = happyGoto action_41 +action_144 (7) = happyGoto action_12 +action_144 (8) = happyGoto action_13 +action_144 (10) = happyGoto action_42 +action_144 (11) = happyGoto action_43 +action_144 (19) = happyGoto action_165 +action_144 (20) = happyGoto action_68 +action_144 (21) = happyGoto action_69 +action_144 (22) = happyGoto action_70 +action_144 (23) = happyGoto action_71 +action_144 (24) = happyGoto action_72 +action_144 (25) = happyGoto action_73 +action_144 (26) = happyGoto action_74 +action_144 (38) = happyGoto action_45 +action_144 (40) = happyGoto action_46 +action_144 (41) = happyGoto action_47 +action_144 _ = happyFail + +action_145 _ = happyReduce_59 + +action_146 _ = happyReduce_109 + +action_147 _ = happyReduce_65 + +action_148 (59) = happyShift action_88 +action_148 (60) = happyShift action_89 +action_148 (71) = happyShift action_90 +action_148 (94) = happyShift action_7 +action_148 (95) = happyShift action_18 +action_148 (98) = happyShift action_57 +action_148 (7) = happyGoto action_12 +action_148 (8) = happyGoto action_80 +action_148 (11) = happyGoto action_81 +action_148 (31) = happyGoto action_109 +action_148 (32) = happyGoto action_83 +action_148 (33) = happyGoto action_84 +action_148 (34) = happyGoto action_85 +action_148 (41) = happyGoto action_86 +action_148 (44) = happyGoto action_87 +action_148 (48) = happyGoto action_164 +action_148 _ = happyReduce_94 + +action_149 _ = happyReduce_61 + +action_150 (61) = happyShift action_163 +action_150 _ = happyFail + +action_151 _ = happyReduce_88 + +action_152 _ = happyReduce_18 + +action_153 _ = happyReduce_71 + +action_154 _ = happyReduce_19 + +action_155 (95) = happyShift action_18 +action_155 (8) = happyGoto action_62 +action_155 (37) = happyGoto action_160 +action_155 (43) = happyGoto action_161 +action_155 (46) = happyGoto action_162 +action_155 _ = happyReduce_89 + +action_156 (94) = happyShift action_7 +action_156 (7) = happyGoto action_12 +action_156 (36) = happyGoto action_157 +action_156 (41) = happyGoto action_158 +action_156 (51) = happyGoto action_159 +action_156 _ = happyFail + +action_157 (89) = happyShift action_189 +action_157 _ = happyReduce_102 + +action_158 (50) = happyGoto action_188 +action_158 _ = happyReduce_100 + +action_159 _ = happyReduce_70 + +action_160 (62) = happyShift action_187 +action_160 _ = happyReduce_90 + +action_161 (66) = happyShift action_186 +action_161 _ = happyFail + +action_162 (90) = happyShift action_185 +action_162 _ = happyFail + +action_163 _ = happyReduce_47 + +action_164 _ = happyReduce_96 + +action_165 (82) = happyShift action_184 +action_165 _ = happyFail + +action_166 _ = happyReduce_27 + +action_167 (60) = happyShift action_49 +action_167 (70) = happyShift action_75 +action_167 (71) = happyShift action_52 +action_167 (76) = happyShift action_76 +action_167 (77) = happyShift action_77 +action_167 (83) = happyShift action_79 +action_167 (88) = happyShift action_53 +action_167 (91) = happyShift action_2 +action_167 (92) = happyShift action_54 +action_167 (93) = happyShift action_55 +action_167 (94) = happyShift action_7 +action_167 (95) = happyShift action_18 +action_167 (97) = happyShift action_56 +action_167 (98) = happyShift action_57 +action_167 (4) = happyGoto action_39 +action_167 (5) = happyGoto action_40 +action_167 (6) = happyGoto action_41 +action_167 (7) = happyGoto action_12 +action_167 (8) = happyGoto action_13 +action_167 (10) = happyGoto action_42 +action_167 (11) = happyGoto action_43 +action_167 (20) = happyGoto action_142 +action_167 (21) = happyGoto action_69 +action_167 (22) = happyGoto action_70 +action_167 (23) = happyGoto action_71 +action_167 (24) = happyGoto action_72 +action_167 (25) = happyGoto action_73 +action_167 (26) = happyGoto action_74 +action_167 (38) = happyGoto action_45 +action_167 (40) = happyGoto action_46 +action_167 (41) = happyGoto action_47 +action_167 (58) = happyGoto action_183 +action_167 _ = happyFail + +action_168 (91) = happyShift action_2 +action_168 (92) = happyShift action_54 +action_168 (93) = happyShift action_55 +action_168 (94) = happyShift action_7 +action_168 (95) = happyShift action_18 +action_168 (97) = happyShift action_56 +action_168 (4) = happyGoto action_39 +action_168 (5) = happyGoto action_40 +action_168 (6) = happyGoto action_41 +action_168 (7) = happyGoto action_12 +action_168 (8) = happyGoto action_13 +action_168 (10) = happyGoto action_42 +action_168 (27) = happyGoto action_177 +action_168 (28) = happyGoto action_178 +action_168 (38) = happyGoto action_179 +action_168 (40) = happyGoto action_180 +action_168 (41) = happyGoto action_181 +action_168 (56) = happyGoto action_182 +action_168 _ = happyFail + +action_169 (67) = happyShift action_176 +action_169 _ = happyReduce_115 + +action_170 (90) = happyShift action_175 +action_170 _ = happyFail + +action_171 (60) = happyShift action_49 +action_171 (70) = happyShift action_75 +action_171 (71) = happyShift action_52 +action_171 (88) = happyShift action_53 +action_171 (91) = happyShift action_2 +action_171 (92) = happyShift action_54 +action_171 (93) = happyShift action_55 +action_171 (94) = happyShift action_7 +action_171 (95) = happyShift action_18 +action_171 (97) = happyShift action_56 +action_171 (98) = happyShift action_57 +action_171 (4) = happyGoto action_39 +action_171 (5) = happyGoto action_40 +action_171 (6) = happyGoto action_41 +action_171 (7) = happyGoto action_12 +action_171 (8) = happyGoto action_13 +action_171 (10) = happyGoto action_42 +action_171 (11) = happyGoto action_43 +action_171 (21) = happyGoto action_173 +action_171 (22) = happyGoto action_70 +action_171 (23) = happyGoto action_71 +action_171 (24) = happyGoto action_72 +action_171 (25) = happyGoto action_73 +action_171 (26) = happyGoto action_74 +action_171 (30) = happyGoto action_174 +action_171 (38) = happyGoto action_45 +action_171 (40) = happyGoto action_46 +action_171 (41) = happyGoto action_47 +action_171 _ = happyReduce_58 + +action_172 _ = happyReduce_41 + +action_173 _ = happyReduce_57 + +action_174 (63) = happyShift action_200 +action_174 _ = happyFail + +action_175 _ = happyReduce_33 + +action_176 (89) = happyShift action_171 +action_176 (29) = happyGoto action_169 +action_176 (57) = happyGoto action_199 +action_176 _ = happyFail + +action_177 (67) = happyShift action_198 +action_177 _ = happyReduce_113 + +action_178 (63) = happyShift action_197 +action_178 _ = happyFail + +action_179 _ = happyReduce_54 + +action_180 _ = happyReduce_55 + +action_181 (95) = happyShift action_18 +action_181 (8) = happyGoto action_13 +action_181 (40) = happyGoto action_196 +action_181 _ = happyReduce_78 + +action_182 (90) = happyShift action_195 +action_182 _ = happyFail + +action_183 _ = happyReduce_118 + +action_184 (60) = happyShift action_49 +action_184 (70) = happyShift action_75 +action_184 (71) = happyShift action_52 +action_184 (76) = happyShift action_76 +action_184 (77) = happyShift action_77 +action_184 (78) = happyShift action_78 +action_184 (83) = happyShift action_79 +action_184 (88) = happyShift action_53 +action_184 (91) = happyShift action_2 +action_184 (92) = happyShift action_54 +action_184 (93) = happyShift action_55 +action_184 (94) = happyShift action_7 +action_184 (95) = happyShift action_18 +action_184 (97) = happyShift action_56 +action_184 (98) = happyShift action_57 +action_184 (4) = happyGoto action_39 +action_184 (5) = happyGoto action_40 +action_184 (6) = happyGoto action_41 +action_184 (7) = happyGoto action_12 +action_184 (8) = happyGoto action_13 +action_184 (10) = happyGoto action_42 +action_184 (11) = happyGoto action_43 +action_184 (19) = happyGoto action_194 +action_184 (20) = happyGoto action_68 +action_184 (21) = happyGoto action_69 +action_184 (22) = happyGoto action_70 +action_184 (23) = happyGoto action_71 +action_184 (24) = happyGoto action_72 +action_184 (25) = happyGoto action_73 +action_184 (26) = happyGoto action_74 +action_184 (38) = happyGoto action_45 +action_184 (40) = happyGoto action_46 +action_184 (41) = happyGoto action_47 +action_184 _ = happyFail + +action_185 _ = happyReduce_69 + +action_186 (59) = happyShift action_88 +action_186 (60) = happyShift action_89 +action_186 (71) = happyShift action_90 +action_186 (94) = happyShift action_7 +action_186 (95) = happyShift action_18 +action_186 (98) = happyShift action_57 +action_186 (7) = happyGoto action_12 +action_186 (8) = happyGoto action_80 +action_186 (11) = happyGoto action_81 +action_186 (31) = happyGoto action_193 +action_186 (32) = happyGoto action_83 +action_186 (33) = happyGoto action_84 +action_186 (34) = happyGoto action_85 +action_186 (41) = happyGoto action_86 +action_186 (44) = happyGoto action_87 +action_186 _ = happyFail + +action_187 (95) = happyShift action_18 +action_187 (8) = happyGoto action_62 +action_187 (37) = happyGoto action_160 +action_187 (43) = happyGoto action_161 +action_187 (46) = happyGoto action_192 +action_187 _ = happyReduce_89 + +action_188 (59) = happyShift action_88 +action_188 (60) = happyShift action_89 +action_188 (94) = happyShift action_7 +action_188 (95) = happyShift action_18 +action_188 (98) = happyShift action_57 +action_188 (7) = happyGoto action_12 +action_188 (8) = happyGoto action_80 +action_188 (11) = happyGoto action_81 +action_188 (34) = happyGoto action_191 +action_188 (41) = happyGoto action_108 +action_188 (44) = happyGoto action_87 +action_188 _ = happyReduce_72 + +action_189 (94) = happyShift action_7 +action_189 (7) = happyGoto action_12 +action_189 (36) = happyGoto action_157 +action_189 (41) = happyGoto action_158 +action_189 (51) = happyGoto action_190 +action_189 _ = happyFail + +action_190 _ = happyReduce_103 + +action_191 _ = happyReduce_101 + +action_192 _ = happyReduce_91 + +action_193 _ = happyReduce_73 + +action_194 _ = happyReduce_30 + +action_195 _ = happyReduce_32 + +action_196 _ = happyReduce_53 + +action_197 (60) = happyShift action_49 +action_197 (70) = happyShift action_75 +action_197 (71) = happyShift action_52 +action_197 (76) = happyShift action_76 +action_197 (77) = happyShift action_77 +action_197 (78) = happyShift action_78 +action_197 (83) = happyShift action_79 +action_197 (88) = happyShift action_53 +action_197 (91) = happyShift action_2 +action_197 (92) = happyShift action_54 +action_197 (93) = happyShift action_55 +action_197 (94) = happyShift action_7 +action_197 (95) = happyShift action_18 +action_197 (97) = happyShift action_56 +action_197 (98) = happyShift action_57 +action_197 (4) = happyGoto action_39 +action_197 (5) = happyGoto action_40 +action_197 (6) = happyGoto action_41 +action_197 (7) = happyGoto action_12 +action_197 (8) = happyGoto action_13 +action_197 (10) = happyGoto action_42 +action_197 (11) = happyGoto action_43 +action_197 (19) = happyGoto action_203 +action_197 (20) = happyGoto action_68 +action_197 (21) = happyGoto action_69 +action_197 (22) = happyGoto action_70 +action_197 (23) = happyGoto action_71 +action_197 (24) = happyGoto action_72 +action_197 (25) = happyGoto action_73 +action_197 (26) = happyGoto action_74 +action_197 (38) = happyGoto action_45 +action_197 (40) = happyGoto action_46 +action_197 (41) = happyGoto action_47 +action_197 _ = happyFail + +action_198 (91) = happyShift action_2 +action_198 (92) = happyShift action_54 +action_198 (93) = happyShift action_55 +action_198 (94) = happyShift action_7 +action_198 (95) = happyShift action_18 +action_198 (97) = happyShift action_56 +action_198 (4) = happyGoto action_39 +action_198 (5) = happyGoto action_40 +action_198 (6) = happyGoto action_41 +action_198 (7) = happyGoto action_12 +action_198 (8) = happyGoto action_13 +action_198 (10) = happyGoto action_42 +action_198 (27) = happyGoto action_177 +action_198 (28) = happyGoto action_178 +action_198 (38) = happyGoto action_179 +action_198 (40) = happyGoto action_180 +action_198 (41) = happyGoto action_181 +action_198 (56) = happyGoto action_202 +action_198 _ = happyFail + +action_199 _ = happyReduce_116 + +action_200 (60) = happyShift action_49 +action_200 (70) = happyShift action_75 +action_200 (71) = happyShift action_52 +action_200 (76) = happyShift action_76 +action_200 (77) = happyShift action_77 +action_200 (78) = happyShift action_78 +action_200 (83) = happyShift action_79 +action_200 (88) = happyShift action_53 +action_200 (91) = happyShift action_2 +action_200 (92) = happyShift action_54 +action_200 (93) = happyShift action_55 +action_200 (94) = happyShift action_7 +action_200 (95) = happyShift action_18 +action_200 (97) = happyShift action_56 +action_200 (98) = happyShift action_57 +action_200 (4) = happyGoto action_39 +action_200 (5) = happyGoto action_40 +action_200 (6) = happyGoto action_41 +action_200 (7) = happyGoto action_12 +action_200 (8) = happyGoto action_13 +action_200 (10) = happyGoto action_42 +action_200 (11) = happyGoto action_43 +action_200 (19) = happyGoto action_201 +action_200 (20) = happyGoto action_68 +action_200 (21) = happyGoto action_69 +action_200 (22) = happyGoto action_70 +action_200 (23) = happyGoto action_71 +action_200 (24) = happyGoto action_72 +action_200 (25) = happyGoto action_73 +action_200 (26) = happyGoto action_74 +action_200 (38) = happyGoto action_45 +action_200 (40) = happyGoto action_46 +action_200 (41) = happyGoto action_47 +action_200 _ = happyFail + +action_201 _ = happyReduce_56 + +action_202 _ = happyReduce_114 + +action_203 _ = happyReduce_52 + +happyReduce_1 = happySpecReduce_1 4 happyReduction_1 +happyReduction_1 (HappyTerminal (PT _ (TL happy_var_1))) + = HappyAbsSyn4 + (happy_var_1 + ) +happyReduction_1 _ = notHappyAtAll + +happyReduce_2 = happySpecReduce_1 5 happyReduction_2 +happyReduction_2 (HappyTerminal (PT _ (TC happy_var_1))) + = HappyAbsSyn5 + ((read ( happy_var_1)) :: Char + ) +happyReduction_2 _ = notHappyAtAll + +happyReduce_3 = happySpecReduce_1 6 happyReduction_3 +happyReduction_3 (HappyTerminal (PT _ (T_Frac happy_var_1))) + = HappyAbsSyn6 + (Frac (happy_var_1) + ) +happyReduction_3 _ = notHappyAtAll + +happyReduce_4 = happySpecReduce_1 7 happyReduction_4 +happyReduction_4 (HappyTerminal (PT _ (T_Uident happy_var_1))) + = HappyAbsSyn7 + (Uident (happy_var_1) + ) +happyReduction_4 _ = notHappyAtAll + +happyReduce_5 = happySpecReduce_1 8 happyReduction_5 +happyReduction_5 (HappyTerminal (PT _ (T_Lident happy_var_1))) + = HappyAbsSyn8 + (Lident (happy_var_1) + ) +happyReduction_5 _ = notHappyAtAll + +happyReduce_6 = happySpecReduce_1 9 happyReduction_6 +happyReduction_6 (HappyTerminal (PT _ (T_USym happy_var_1))) + = HappyAbsSyn9 + (USym (happy_var_1) + ) +happyReduction_6 _ = notHappyAtAll + +happyReduce_7 = happySpecReduce_1 10 happyReduction_7 +happyReduction_7 (HappyTerminal (PT _ (T_Number happy_var_1))) + = HappyAbsSyn10 + (Number (happy_var_1) + ) +happyReduction_7 _ = notHappyAtAll + +happyReduce_8 = happySpecReduce_1 11 happyReduction_8 +happyReduction_8 (HappyTerminal (PT _ (T_Count happy_var_1))) + = HappyAbsSyn11 + (Count (happy_var_1) + ) +happyReduction_8 _ = notHappyAtAll + +happyReduce_9 = happyReduce 8 12 happyReduction_9 +happyReduction_9 (_ `HappyStk` + (HappyAbsSyn55 happy_var_7) `HappyStk` + _ `HappyStk` + _ `HappyStk` + (HappyAbsSyn13 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn42 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn12 + (Module happy_var_2 happy_var_4 happy_var_7 + ) `HappyStk` happyRest + +happyReduce_10 = happySpecReduce_1 13 happyReduction_10 +happyReduction_10 _ + = HappyAbsSyn13 + (ExpAllD + ) + +happyReduce_11 = happySpecReduce_3 13 happyReduction_11 +happyReduction_11 _ + (HappyAbsSyn49 happy_var_2) + _ + = HappyAbsSyn13 + (ExpListD happy_var_2 + ) +happyReduction_11 _ _ _ = notHappyAtAll + +happyReduce_12 = happySpecReduce_2 14 happyReduction_12 +happyReduction_12 (HappyAbsSyn15 happy_var_2) + (HappyAbsSyn41 happy_var_1) + = HappyAbsSyn14 + (TypeEx happy_var_1 happy_var_2 + ) +happyReduction_12 _ _ = notHappyAtAll + +happyReduce_13 = happySpecReduce_1 14 happyReduction_13 +happyReduction_13 (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn14 + (VarEx happy_var_1 + ) +happyReduction_13 _ = notHappyAtAll + +happyReduce_14 = happySpecReduce_0 15 happyReduction_14 +happyReduction_14 = HappyAbsSyn15 + (Neither + ) + +happyReduce_15 = happySpecReduce_3 15 happyReduction_15 +happyReduction_15 _ + _ + _ + = HappyAbsSyn15 + (Decon + ) + +happyReduce_16 = happySpecReduce_3 15 happyReduction_16 +happyReduction_16 _ + _ + _ + = HappyAbsSyn15 + (Both + ) + +happyReduce_17 = happySpecReduce_3 16 happyReduction_17 +happyReduction_17 (HappyAbsSyn17 happy_var_3) + (HappyAbsSyn42 happy_var_2) + _ + = HappyAbsSyn16 + (ImportD happy_var_2 happy_var_3 + ) +happyReduction_17 _ _ _ = notHappyAtAll + +happyReduce_18 = happyReduce 5 16 happyReduction_18 +happyReduction_18 ((HappyAbsSyn31 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyAbsSyn40 happy_var_3) `HappyStk` + (HappyAbsSyn18 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn16 + (ExternD happy_var_2 happy_var_3 happy_var_5 + ) `HappyStk` happyRest + +happyReduce_19 = happyReduce 5 16 happyReduction_19 +happyReduction_19 ((HappyAbsSyn35 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyAbsSyn47 happy_var_3) `HappyStk` + (HappyAbsSyn41 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn16 + (TypeD happy_var_2 (reverse happy_var_3) happy_var_5 + ) `HappyStk` happyRest + +happyReduce_20 = happySpecReduce_3 16 happyReduction_20 +happyReduction_20 (HappyAbsSyn31 happy_var_3) + _ + (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn16 + (AscribeD happy_var_1 happy_var_3 + ) +happyReduction_20 _ _ _ = notHappyAtAll + +happyReduce_21 = happySpecReduce_3 16 happyReduction_21 +happyReduction_21 (HappyAbsSyn19 happy_var_3) + _ + (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn16 + (VarD happy_var_1 happy_var_3 + ) +happyReduction_21 _ _ _ = notHappyAtAll + +happyReduce_22 = happyReduce 4 16 happyReduction_22 +happyReduction_22 ((HappyAbsSyn19 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn45 happy_var_2) `HappyStk` + (HappyAbsSyn40 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn16 + (ProcD happy_var_1 happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_23 = happySpecReduce_2 17 happyReduction_23 +happyReduction_23 (HappyAbsSyn41 happy_var_2) + _ + = HappyAbsSyn17 + (AsAS happy_var_2 + ) +happyReduction_23 _ _ = notHappyAtAll + +happyReduce_24 = happySpecReduce_0 17 happyReduction_24 +happyReduction_24 = HappyAbsSyn17 + (EmptyAS + ) + +happyReduce_25 = happySpecReduce_1 18 happyReduction_25 +happyReduction_25 (HappyAbsSyn4 happy_var_1) + = HappyAbsSyn18 + (SomeNm happy_var_1 + ) +happyReduction_25 _ = notHappyAtAll + +happyReduce_26 = happySpecReduce_0 18 happyReduction_26 +happyReduction_26 = HappyAbsSyn18 + (NoneNm + ) + +happyReduce_27 = happyReduce 4 19 happyReduction_27 +happyReduction_27 (_ `HappyStk` + (HappyAbsSyn45 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn19 + (BlockE happy_var_3 + ) `HappyStk` happyRest + +happyReduce_28 = happySpecReduce_1 19 happyReduction_28 +happyReduction_28 (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn19 + (happy_var_1 + ) +happyReduction_28 _ = notHappyAtAll + +happyReduce_29 = happySpecReduce_3 20 happyReduction_29 +happyReduction_29 (HappyAbsSyn19 happy_var_3) + _ + (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn19 + (LetS happy_var_1 happy_var_3 + ) +happyReduction_29 _ _ _ = notHappyAtAll + +happyReduce_30 = happyReduce 6 20 happyReduction_30 +happyReduction_30 ((HappyAbsSyn19 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn19 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn19 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn19 + (LetE happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest + +happyReduce_31 = happySpecReduce_3 20 happyReduction_31 +happyReduction_31 (HappyAbsSyn19 happy_var_3) + _ + (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn19 + (StoreE happy_var_1 happy_var_3 + ) +happyReduction_31 _ _ _ = notHappyAtAll + +happyReduce_32 = happyReduce 6 20 happyReduction_32 +happyReduction_32 (_ `HappyStk` + (HappyAbsSyn56 happy_var_5) `HappyStk` + _ `HappyStk` + _ `HappyStk` + (HappyAbsSyn19 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn19 + (CaseE happy_var_2 happy_var_5 + ) `HappyStk` happyRest + +happyReduce_33 = happyReduce 5 20 happyReduction_33 +happyReduction_33 (_ `HappyStk` + (HappyAbsSyn57 happy_var_4) `HappyStk` + _ `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn19 + (BranchE happy_var_4 + ) `HappyStk` happyRest + +happyReduce_34 = happySpecReduce_1 20 happyReduction_34 +happyReduction_34 (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn19 + (happy_var_1 + ) +happyReduction_34 _ = notHappyAtAll + +happyReduce_35 = happySpecReduce_3 21 happyReduction_35 +happyReduction_35 (HappyAbsSyn19 happy_var_3) + (HappyAbsSyn9 happy_var_2) + (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn19 + (BinOpE happy_var_1 happy_var_2 happy_var_3 + ) +happyReduction_35 _ _ _ = notHappyAtAll + +happyReduce_36 = happySpecReduce_1 21 happyReduction_36 +happyReduction_36 (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn19 + (happy_var_1 + ) +happyReduction_36 _ = notHappyAtAll + +happyReduce_37 = happySpecReduce_2 22 happyReduction_37 +happyReduction_37 (HappyAbsSyn19 happy_var_2) + (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn19 + (AppE happy_var_1 happy_var_2 + ) +happyReduction_37 _ _ = notHappyAtAll + +happyReduce_38 = happySpecReduce_1 22 happyReduction_38 +happyReduction_38 (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn19 + (happy_var_1 + ) +happyReduction_38 _ = notHappyAtAll + +happyReduce_39 = happySpecReduce_2 23 happyReduction_39 +happyReduction_39 (HappyAbsSyn19 happy_var_2) + (HappyAbsSyn26 happy_var_1) + = HappyAbsSyn19 + (UnOpE happy_var_1 happy_var_2 + ) +happyReduction_39 _ _ = notHappyAtAll + +happyReduce_40 = happySpecReduce_1 23 happyReduction_40 +happyReduction_40 (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn19 + (happy_var_1 + ) +happyReduction_40 _ = notHappyAtAll + +happyReduce_41 = happyReduce 4 24 happyReduction_41 +happyReduction_41 (_ `HappyStk` + (HappyAbsSyn19 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyAbsSyn19 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn19 + (IdxE happy_var_1 happy_var_3 + ) `HappyStk` happyRest + +happyReduce_42 = happySpecReduce_3 24 happyReduction_42 +happyReduction_42 (HappyAbsSyn43 happy_var_3) + _ + (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn19 + (FldE happy_var_1 happy_var_3 + ) +happyReduction_42 _ _ _ = notHappyAtAll + +happyReduce_43 = happySpecReduce_1 24 happyReduction_43 +happyReduction_43 (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn19 + (happy_var_1 + ) +happyReduction_43 _ = notHappyAtAll + +happyReduce_44 = happyReduce 4 25 happyReduction_44 +happyReduction_44 (_ `HappyStk` + (HappyAbsSyn45 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn19 + (ArrayE happy_var_3 + ) `HappyStk` happyRest + +happyReduce_45 = happySpecReduce_3 25 happyReduction_45 +happyReduction_45 _ + (HappyAbsSyn53 happy_var_2) + _ + = HappyAbsSyn19 + (RecordE happy_var_2 + ) +happyReduction_45 _ _ _ = notHappyAtAll + +happyReduce_46 = happySpecReduce_3 25 happyReduction_46 +happyReduction_46 _ + (HappyAbsSyn45 happy_var_2) + _ + = HappyAbsSyn19 + (TupleE happy_var_2 + ) +happyReduction_46 _ _ _ = notHappyAtAll + +happyReduce_47 = happyReduce 5 25 happyReduction_47 +happyReduction_47 (_ `HappyStk` + (HappyAbsSyn31 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn19 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn19 + (AscribeE happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_48 = happySpecReduce_1 25 happyReduction_48 +happyReduction_48 (HappyAbsSyn11 happy_var_1) + = HappyAbsSyn19 + (CountE happy_var_1 + ) +happyReduction_48 _ = notHappyAtAll + +happyReduce_49 = happySpecReduce_1 25 happyReduction_49 +happyReduction_49 (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn19 + (VarE happy_var_1 + ) +happyReduction_49 _ = notHappyAtAll + +happyReduce_50 = happySpecReduce_1 25 happyReduction_50 +happyReduction_50 (HappyAbsSyn38 happy_var_1) + = HappyAbsSyn19 + (LitE happy_var_1 + ) +happyReduction_50 _ = notHappyAtAll + +happyReduce_51 = happySpecReduce_1 26 happyReduction_51 +happyReduction_51 _ + = HappyAbsSyn26 + (Load + ) + +happyReduce_52 = happySpecReduce_3 27 happyReduction_52 +happyReduction_52 (HappyAbsSyn19 happy_var_3) + _ + (HappyAbsSyn28 happy_var_1) + = HappyAbsSyn27 + (CaseAlt happy_var_1 happy_var_3 + ) +happyReduction_52 _ _ _ = notHappyAtAll + +happyReduce_53 = happySpecReduce_2 28 happyReduction_53 +happyReduction_53 (HappyAbsSyn40 happy_var_2) + (HappyAbsSyn41 happy_var_1) + = HappyAbsSyn28 + (ConP happy_var_1 happy_var_2 + ) +happyReduction_53 _ _ = notHappyAtAll + +happyReduce_54 = happySpecReduce_1 28 happyReduction_54 +happyReduction_54 (HappyAbsSyn38 happy_var_1) + = HappyAbsSyn28 + (LitP happy_var_1 + ) +happyReduction_54 _ = notHappyAtAll + +happyReduce_55 = happySpecReduce_1 28 happyReduction_55 +happyReduction_55 (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn28 + (VarP happy_var_1 + ) +happyReduction_55 _ = notHappyAtAll + +happyReduce_56 = happyReduce 4 29 happyReduction_56 +happyReduction_56 ((HappyAbsSyn19 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn30 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn29 + (BranchAlt happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_57 = happySpecReduce_1 30 happyReduction_57 +happyReduction_57 (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn30 + (BoolBP happy_var_1 + ) +happyReduction_57 _ = notHappyAtAll + +happyReduce_58 = happySpecReduce_0 30 happyReduction_58 +happyReduction_58 = HappyAbsSyn30 + (DefaultBP + ) + +happyReduce_59 = happySpecReduce_3 31 happyReduction_59 +happyReduction_59 (HappyAbsSyn31 happy_var_3) + _ + (HappyAbsSyn31 happy_var_1) + = HappyAbsSyn31 + (TyFun happy_var_1 happy_var_3 + ) +happyReduction_59 _ _ _ = notHappyAtAll + +happyReduce_60 = happySpecReduce_1 31 happyReduction_60 +happyReduction_60 (HappyAbsSyn31 happy_var_1) + = HappyAbsSyn31 + (happy_var_1 + ) +happyReduction_60 _ = notHappyAtAll + +happyReduce_61 = happySpecReduce_3 32 happyReduction_61 +happyReduction_61 (HappyAbsSyn31 happy_var_3) + (HappyAbsSyn31 happy_var_2) + _ + = HappyAbsSyn31 + (TyArray happy_var_2 happy_var_3 + ) +happyReduction_61 _ _ _ = notHappyAtAll + +happyReduce_62 = happySpecReduce_2 32 happyReduction_62 +happyReduction_62 (HappyAbsSyn48 happy_var_2) + (HappyAbsSyn41 happy_var_1) + = HappyAbsSyn31 + (TyConstr happy_var_1 happy_var_2 + ) +happyReduction_62 _ _ = notHappyAtAll + +happyReduce_63 = happySpecReduce_1 32 happyReduction_63 +happyReduction_63 (HappyAbsSyn31 happy_var_1) + = HappyAbsSyn31 + (happy_var_1 + ) +happyReduction_63 _ = notHappyAtAll + +happyReduce_64 = happySpecReduce_1 33 happyReduction_64 +happyReduction_64 (HappyAbsSyn31 happy_var_1) + = HappyAbsSyn31 + (happy_var_1 + ) +happyReduction_64 _ = notHappyAtAll + +happyReduce_65 = happySpecReduce_3 34 happyReduction_65 +happyReduction_65 _ + (HappyAbsSyn48 happy_var_2) + _ + = HappyAbsSyn31 + (TyTuple happy_var_2 + ) +happyReduction_65 _ _ _ = notHappyAtAll + +happyReduce_66 = happySpecReduce_1 34 happyReduction_66 +happyReduction_66 (HappyAbsSyn11 happy_var_1) + = HappyAbsSyn31 + (TyCount happy_var_1 + ) +happyReduction_66 _ = notHappyAtAll + +happyReduce_67 = happySpecReduce_1 34 happyReduction_67 +happyReduction_67 (HappyAbsSyn44 happy_var_1) + = HappyAbsSyn31 + (TyVarT happy_var_1 + ) +happyReduction_67 _ = notHappyAtAll + +happyReduce_68 = happySpecReduce_1 34 happyReduction_68 +happyReduction_68 (HappyAbsSyn41 happy_var_1) + = HappyAbsSyn31 + (TyConstr0 happy_var_1 + ) +happyReduction_68 _ = notHappyAtAll + +happyReduce_69 = happySpecReduce_3 35 happyReduction_69 +happyReduction_69 _ + (HappyAbsSyn46 happy_var_2) + _ + = HappyAbsSyn35 + (TyRecord happy_var_2 + ) +happyReduction_69 _ _ _ = notHappyAtAll + +happyReduce_70 = happySpecReduce_2 35 happyReduction_70 +happyReduction_70 (HappyAbsSyn51 happy_var_2) + _ + = HappyAbsSyn35 + (TyTagged happy_var_2 + ) +happyReduction_70 _ _ = notHappyAtAll + +happyReduce_71 = happySpecReduce_1 35 happyReduction_71 +happyReduction_71 (HappyAbsSyn31 happy_var_1) + = HappyAbsSyn35 + (TySyn happy_var_1 + ) +happyReduction_71 _ = notHappyAtAll + +happyReduce_72 = happySpecReduce_2 36 happyReduction_72 +happyReduction_72 (HappyAbsSyn48 happy_var_2) + (HappyAbsSyn41 happy_var_1) + = HappyAbsSyn36 + (ConC happy_var_1 (reverse happy_var_2) + ) +happyReduction_72 _ _ = notHappyAtAll + +happyReduce_73 = happySpecReduce_3 37 happyReduction_73 +happyReduction_73 (HappyAbsSyn31 happy_var_3) + _ + (HappyAbsSyn43 happy_var_1) + = HappyAbsSyn37 + (FieldT happy_var_1 happy_var_3 + ) +happyReduction_73 _ _ _ = notHappyAtAll + +happyReduce_74 = happySpecReduce_1 38 happyReduction_74 +happyReduction_74 (HappyAbsSyn5 happy_var_1) + = HappyAbsSyn38 + (CharL happy_var_1 + ) +happyReduction_74 _ = notHappyAtAll + +happyReduce_75 = happySpecReduce_1 38 happyReduction_75 +happyReduction_75 (HappyAbsSyn4 happy_var_1) + = HappyAbsSyn38 + (StringL happy_var_1 + ) +happyReduction_75 _ = notHappyAtAll + +happyReduce_76 = happySpecReduce_1 38 happyReduction_76 +happyReduction_76 (HappyAbsSyn10 happy_var_1) + = HappyAbsSyn38 + (IntL happy_var_1 + ) +happyReduction_76 _ = notHappyAtAll + +happyReduce_77 = happySpecReduce_1 38 happyReduction_77 +happyReduction_77 (HappyAbsSyn6 happy_var_1) + = HappyAbsSyn38 + (FracL happy_var_1 + ) +happyReduction_77 _ = notHappyAtAll + +happyReduce_78 = happySpecReduce_1 38 happyReduction_78 +happyReduction_78 (HappyAbsSyn41 happy_var_1) + = HappyAbsSyn38 + (EnumL happy_var_1 + ) +happyReduction_78 _ = notHappyAtAll + +happyReduce_79 = happySpecReduce_3 39 happyReduction_79 +happyReduction_79 (HappyAbsSyn19 happy_var_3) + _ + (HappyAbsSyn43 happy_var_1) + = HappyAbsSyn39 + (FieldD happy_var_1 happy_var_3 + ) +happyReduction_79 _ _ _ = notHappyAtAll + +happyReduce_80 = happySpecReduce_1 40 happyReduction_80 +happyReduction_80 (HappyAbsSyn8 happy_var_1) + = HappyAbsSyn40 + (Var happy_var_1 + ) +happyReduction_80 _ = notHappyAtAll + +happyReduce_81 = happySpecReduce_1 41 happyReduction_81 +happyReduction_81 (HappyAbsSyn7 happy_var_1) + = HappyAbsSyn41 + (Con happy_var_1 + ) +happyReduction_81 _ = notHappyAtAll + +happyReduce_82 = happySpecReduce_1 42 happyReduction_82 +happyReduction_82 (HappyAbsSyn7 happy_var_1) + = HappyAbsSyn42 + (Modid happy_var_1 + ) +happyReduction_82 _ = notHappyAtAll + +happyReduce_83 = happySpecReduce_1 43 happyReduction_83 +happyReduction_83 (HappyAbsSyn8 happy_var_1) + = HappyAbsSyn43 + (Field happy_var_1 + ) +happyReduction_83 _ = notHappyAtAll + +happyReduce_84 = happySpecReduce_1 44 happyReduction_84 +happyReduction_84 (HappyAbsSyn8 happy_var_1) + = HappyAbsSyn44 + (VarTV happy_var_1 + ) +happyReduction_84 _ = notHappyAtAll + +happyReduce_85 = happySpecReduce_2 44 happyReduction_85 +happyReduction_85 (HappyAbsSyn8 happy_var_2) + _ + = HappyAbsSyn44 + (CntTV happy_var_2 + ) +happyReduction_85 _ _ = notHappyAtAll + +happyReduce_86 = happySpecReduce_0 45 happyReduction_86 +happyReduction_86 = HappyAbsSyn45 + ([] + ) + +happyReduce_87 = happySpecReduce_1 45 happyReduction_87 +happyReduction_87 (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn45 + ((:[]) happy_var_1 + ) +happyReduction_87 _ = notHappyAtAll + +happyReduce_88 = happySpecReduce_3 45 happyReduction_88 +happyReduction_88 (HappyAbsSyn45 happy_var_3) + _ + (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn45 + ((:) happy_var_1 happy_var_3 + ) +happyReduction_88 _ _ _ = notHappyAtAll + +happyReduce_89 = happySpecReduce_0 46 happyReduction_89 +happyReduction_89 = HappyAbsSyn46 + ([] + ) + +happyReduce_90 = happySpecReduce_1 46 happyReduction_90 +happyReduction_90 (HappyAbsSyn37 happy_var_1) + = HappyAbsSyn46 + ((:[]) happy_var_1 + ) +happyReduction_90 _ = notHappyAtAll + +happyReduce_91 = happySpecReduce_3 46 happyReduction_91 +happyReduction_91 (HappyAbsSyn46 happy_var_3) + _ + (HappyAbsSyn37 happy_var_1) + = HappyAbsSyn46 + ((:) happy_var_1 happy_var_3 + ) +happyReduction_91 _ _ _ = notHappyAtAll + +happyReduce_92 = happySpecReduce_0 47 happyReduction_92 +happyReduction_92 = HappyAbsSyn47 + ([] + ) + +happyReduce_93 = happySpecReduce_2 47 happyReduction_93 +happyReduction_93 (HappyAbsSyn44 happy_var_2) + (HappyAbsSyn47 happy_var_1) + = HappyAbsSyn47 + (flip (:) happy_var_1 happy_var_2 + ) +happyReduction_93 _ _ = notHappyAtAll + +happyReduce_94 = happySpecReduce_0 48 happyReduction_94 +happyReduction_94 = HappyAbsSyn48 + ([] + ) + +happyReduce_95 = happySpecReduce_1 48 happyReduction_95 +happyReduction_95 (HappyAbsSyn31 happy_var_1) + = HappyAbsSyn48 + ((:[]) happy_var_1 + ) +happyReduction_95 _ = notHappyAtAll + +happyReduce_96 = happySpecReduce_3 48 happyReduction_96 +happyReduction_96 (HappyAbsSyn48 happy_var_3) + _ + (HappyAbsSyn31 happy_var_1) + = HappyAbsSyn48 + ((:) happy_var_1 happy_var_3 + ) +happyReduction_96 _ _ _ = notHappyAtAll + +happyReduce_97 = happySpecReduce_0 49 happyReduction_97 +happyReduction_97 = HappyAbsSyn49 + ([] + ) + +happyReduce_98 = happySpecReduce_1 49 happyReduction_98 +happyReduction_98 (HappyAbsSyn14 happy_var_1) + = HappyAbsSyn49 + ((:[]) happy_var_1 + ) +happyReduction_98 _ = notHappyAtAll + +happyReduce_99 = happySpecReduce_3 49 happyReduction_99 +happyReduction_99 (HappyAbsSyn49 happy_var_3) + _ + (HappyAbsSyn14 happy_var_1) + = HappyAbsSyn49 + ((:) happy_var_1 happy_var_3 + ) +happyReduction_99 _ _ _ = notHappyAtAll + +happyReduce_100 = happySpecReduce_0 50 happyReduction_100 +happyReduction_100 = HappyAbsSyn48 + ([] + ) + +happyReduce_101 = happySpecReduce_2 50 happyReduction_101 +happyReduction_101 (HappyAbsSyn31 happy_var_2) + (HappyAbsSyn48 happy_var_1) + = HappyAbsSyn48 + (flip (:) happy_var_1 happy_var_2 + ) +happyReduction_101 _ _ = notHappyAtAll + +happyReduce_102 = happySpecReduce_1 51 happyReduction_102 +happyReduction_102 (HappyAbsSyn36 happy_var_1) + = HappyAbsSyn51 + ((:[]) happy_var_1 + ) +happyReduction_102 _ = notHappyAtAll + +happyReduce_103 = happySpecReduce_3 51 happyReduction_103 +happyReduction_103 (HappyAbsSyn51 happy_var_3) + _ + (HappyAbsSyn36 happy_var_1) + = HappyAbsSyn51 + ((:) happy_var_1 happy_var_3 + ) +happyReduction_103 _ _ _ = notHappyAtAll + +happyReduce_104 = happySpecReduce_1 52 happyReduction_104 +happyReduction_104 (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn45 + ((:[]) happy_var_1 + ) +happyReduction_104 _ = notHappyAtAll + +happyReduce_105 = happySpecReduce_2 52 happyReduction_105 +happyReduction_105 (HappyAbsSyn45 happy_var_2) + (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn45 + ((:) happy_var_1 happy_var_2 + ) +happyReduction_105 _ _ = notHappyAtAll + +happyReduce_106 = happySpecReduce_1 53 happyReduction_106 +happyReduction_106 (HappyAbsSyn39 happy_var_1) + = HappyAbsSyn53 + ((:[]) happy_var_1 + ) +happyReduction_106 _ = notHappyAtAll + +happyReduce_107 = happySpecReduce_3 53 happyReduction_107 +happyReduction_107 (HappyAbsSyn53 happy_var_3) + _ + (HappyAbsSyn39 happy_var_1) + = HappyAbsSyn53 + ((:) happy_var_1 happy_var_3 + ) +happyReduction_107 _ _ _ = notHappyAtAll + +happyReduce_108 = happySpecReduce_1 54 happyReduction_108 +happyReduction_108 (HappyAbsSyn31 happy_var_1) + = HappyAbsSyn48 + ((:[]) happy_var_1 + ) +happyReduction_108 _ = notHappyAtAll + +happyReduce_109 = happySpecReduce_2 54 happyReduction_109 +happyReduction_109 (HappyAbsSyn48 happy_var_2) + (HappyAbsSyn31 happy_var_1) + = HappyAbsSyn48 + ((:) happy_var_1 happy_var_2 + ) +happyReduction_109 _ _ = notHappyAtAll + +happyReduce_110 = happySpecReduce_0 55 happyReduction_110 +happyReduction_110 = HappyAbsSyn55 + ([] + ) + +happyReduce_111 = happySpecReduce_1 55 happyReduction_111 +happyReduction_111 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn55 + ((:[]) happy_var_1 + ) +happyReduction_111 _ = notHappyAtAll + +happyReduce_112 = happySpecReduce_3 55 happyReduction_112 +happyReduction_112 (HappyAbsSyn55 happy_var_3) + _ + (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn55 + ((:) happy_var_1 happy_var_3 + ) +happyReduction_112 _ _ _ = notHappyAtAll + +happyReduce_113 = happySpecReduce_1 56 happyReduction_113 +happyReduction_113 (HappyAbsSyn27 happy_var_1) + = HappyAbsSyn56 + ((:[]) happy_var_1 + ) +happyReduction_113 _ = notHappyAtAll + +happyReduce_114 = happySpecReduce_3 56 happyReduction_114 +happyReduction_114 (HappyAbsSyn56 happy_var_3) + _ + (HappyAbsSyn27 happy_var_1) + = HappyAbsSyn56 + ((:) happy_var_1 happy_var_3 + ) +happyReduction_114 _ _ _ = notHappyAtAll + +happyReduce_115 = happySpecReduce_1 57 happyReduction_115 +happyReduction_115 (HappyAbsSyn29 happy_var_1) + = HappyAbsSyn57 + ((:[]) happy_var_1 + ) +happyReduction_115 _ = notHappyAtAll + +happyReduce_116 = happySpecReduce_3 57 happyReduction_116 +happyReduction_116 (HappyAbsSyn57 happy_var_3) + _ + (HappyAbsSyn29 happy_var_1) + = HappyAbsSyn57 + ((:) happy_var_1 happy_var_3 + ) +happyReduction_116 _ _ _ = notHappyAtAll + +happyReduce_117 = happySpecReduce_1 58 happyReduction_117 +happyReduction_117 (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn45 + ((:[]) happy_var_1 + ) +happyReduction_117 _ = notHappyAtAll + +happyReduce_118 = happySpecReduce_3 58 happyReduction_118 +happyReduction_118 (HappyAbsSyn45 happy_var_3) + _ + (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn45 + ((:) happy_var_1 happy_var_3 + ) +happyReduction_118 _ _ _ = notHappyAtAll + +happyNewToken action sts stk [] = + action 100 100 notHappyAtAll (HappyState action) sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = action i i tk (HappyState action) sts stk tks in + case tk of { + PT _ (TS _ 1) -> cont 59; + PT _ (TS _ 2) -> cont 60; + PT _ (TS _ 3) -> cont 61; + PT _ (TS _ 4) -> cont 62; + PT _ (TS _ 5) -> cont 63; + PT _ (TS _ 6) -> cont 64; + PT _ (TS _ 7) -> cont 65; + PT _ (TS _ 8) -> cont 66; + PT _ (TS _ 9) -> cont 67; + PT _ (TS _ 10) -> cont 68; + PT _ (TS _ 11) -> cont 69; + PT _ (TS _ 12) -> cont 70; + PT _ (TS _ 13) -> cont 71; + PT _ (TS _ 14) -> cont 72; + PT _ (TS _ 15) -> cont 73; + PT _ (TS _ 16) -> cont 74; + PT _ (TS _ 17) -> cont 75; + PT _ (TS _ 18) -> cont 76; + PT _ (TS _ 19) -> cont 77; + PT _ (TS _ 20) -> cont 78; + PT _ (TS _ 21) -> cont 79; + PT _ (TS _ 22) -> cont 80; + PT _ (TS _ 23) -> cont 81; + PT _ (TS _ 24) -> cont 82; + PT _ (TS _ 25) -> cont 83; + PT _ (TS _ 26) -> cont 84; + PT _ (TS _ 27) -> cont 85; + PT _ (TS _ 28) -> cont 86; + PT _ (TS _ 29) -> cont 87; + PT _ (TS _ 30) -> cont 88; + PT _ (TS _ 31) -> cont 89; + PT _ (TS _ 32) -> cont 90; + PT _ (TL happy_dollar_dollar) -> cont 91; + PT _ (TC happy_dollar_dollar) -> cont 92; + PT _ (T_Frac happy_dollar_dollar) -> cont 93; + PT _ (T_Uident happy_dollar_dollar) -> cont 94; + PT _ (T_Lident happy_dollar_dollar) -> cont 95; + PT _ (T_USym happy_dollar_dollar) -> cont 96; + PT _ (T_Number happy_dollar_dollar) -> cont 97; + PT _ (T_Count happy_dollar_dollar) -> cont 98; + _ -> cont 99; + _ -> happyError' (tk:tks) + } + +happyError_ tk tks = happyError' (tk:tks) + +happyThen :: () => Err a -> (a -> Err b) -> Err b +happyThen = (thenM) +happyReturn :: () => a -> Err a +happyReturn = (returnM) +happyThen1 m k tks = (thenM) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> Err a +happyReturn1 = \a tks -> (returnM) a +happyError' :: () => [(Token)] -> Err a +happyError' = happyError + +pModule tks = happySomeParser where + happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn12 z -> happyReturn z; _other -> notHappyAtAll }) + +happySeq = happyDontSeq + + +returnM :: a -> Err a +returnM = return + +thenM :: Err a -> (a -> Err b) -> Err b +thenM = (>>=) + +happyError :: [Token] -> Err a +happyError ts = + Bad $ "syntax error at " ++ tokenPos ts ++ + case ts of + [] -> [] + [Err _] -> " due to lexer error" + _ -> " before " ++ unwords (map (id . prToken) (take 4 ts)) + +myLexer = tokens +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 30 "templates/GenericTemplate.hs" #-} + + + + + + + + +{-# LINE 51 "templates/GenericTemplate.hs" #-} + +{-# LINE 61 "templates/GenericTemplate.hs" #-} + +{-# LINE 70 "templates/GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is (1), it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + +{-# LINE 148 "templates/GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + + + +newtype HappyState b c = HappyState + (Int -> -- token number + Int -> -- token number (yes, again) + b -> -- token semantic value + HappyState b c -> -- current state + [HappyState b c] -> -- state stack + c) + + + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state (1) tk st sts stk@(x `HappyStk` _) = + let (i) = (case x of { HappyErrorToken (i) -> i }) in +-- trace "shifting the error token" $ + new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk + = action nt j tk st ((st):(sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k - ((1) :: Int)) sts of + sts1@(((st1@(HappyState (action))):(_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (action nt j tk st1 sts1 r) + +happyMonadReduce k nt fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where (sts1@(((st1@(HappyState (action))):(_)))) = happyDrop k ((st):(sts)) + drop_stk = happyDropStk k stk + +happyMonad2Reduce k nt fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + where (sts1@(((st1@(HappyState (action))):(_)))) = happyDrop k ((st):(sts)) + drop_stk = happyDropStk k stk + + + + + + new_state = action + + +happyDrop (0) l = l +happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t + +happyDropStk (0) l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + +{-# LINE 246 "templates/GenericTemplate.hs" #-} +happyGoto action j tk st = action j j tk (HappyState action) + + +----------------------------------------------------------------------------- +-- Error recovery ((1) is the error token) + +-- parse error if we are in recovery and we fail again +happyFail (1) tk old_st _ stk = +-- trace "failing" $ + happyError_ tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail (1) tk old_st (((HappyState (action))):(sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (HappyState (action)) sts stk = +-- trace "entering error recovery" $ + action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + + + + + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + +{-# LINE 311 "templates/GenericTemplate.hs" #-} +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/Language/Pec/Print.hs b/Language/Pec/Print.hs new file mode 100644 --- /dev/null +++ b/Language/Pec/Print.hs @@ -0,0 +1,314 @@ +{-# OPTIONS -fno-warn-incomplete-patterns #-} +module Language.Pec.Print where + +-- pretty-printer generated by the BNF converter + +import Language.Pec.Abs +import Data.Char + + +-- the top-level printing method +printTree :: Print a => a -> String +printTree = render . prt 0 + +type Doc = [ShowS] -> [ShowS] + +doc :: ShowS -> Doc +doc = (:) + +render :: Doc -> String +render d = rend 0 (map ($ "") $ d []) "" where + rend i ss = case ss of + "[" :ts -> showChar '[' . rend i ts + "(" :ts -> showChar '(' . rend i ts + "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts + "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts + "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts + ";" :ts -> showChar ';' . new i . rend i ts + t : "," :ts -> showString t . space "," . rend i ts + t : ")" :ts -> showString t . showChar ')' . rend i ts + t : "]" :ts -> showString t . showChar ']' . rend i ts + t :ts -> space t . rend i ts + _ -> id + new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace + space t = showString t . (\s -> if null s then "" else (' ':s)) + +parenth :: Doc -> Doc +parenth ss = doc (showChar '(') . ss . doc (showChar ')') + +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +concatD :: [Doc] -> Doc +concatD = foldr (.) id + +replicateS :: Int -> ShowS -> ShowS +replicateS n f = concatS (replicate n f) + +-- the printer class does the job +class Print a where + prt :: Int -> a -> Doc + prtList :: [a] -> Doc + prtList = concatD . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') + prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') + +mkEsc :: Char -> Char -> ShowS +mkEsc q s = case s of + _ | s == q -> showChar '\\' . showChar s + '\\'-> showString "\\\\" + '\n' -> showString "\\n" + '\t' -> showString "\\t" + _ -> showChar s + +prPrec :: Int -> Int -> Doc -> Doc +prPrec i j = if j prPrec i 0 (concatD [doc (showString "module") , prt 0 modid , doc (showString "exports") , prt 0 exportdecl , doc (showString "where") , doc (showString "{") , prt 0 topdecls , doc (showString "}")]) + + +instance Print ExportDecl where + prt i e = case e of + ExpAllD -> prPrec i 0 (concatD [doc (showString "all")]) + ExpListD exports -> prPrec i 0 (concatD [doc (showString "(") , prt 0 exports , doc (showString ")")]) + + +instance Print Export where + prt i e = case e of + TypeEx con spec -> prPrec i 0 (concatD [prt 0 con , prt 0 spec]) + VarEx var -> prPrec i 0 (concatD [prt 0 var]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print Spec where + prt i e = case e of + Neither -> prPrec i 0 (concatD []) + Decon -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ".") , doc (showString ")")]) + Both -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "..") , doc (showString ")")]) + + +instance Print TopDecl where + prt i e = case e of + ImportD modid asspec -> prPrec i 0 (concatD [doc (showString "import") , prt 0 modid , prt 0 asspec]) + ExternD extnm var type' -> prPrec i 0 (concatD [doc (showString "extern") , prt 0 extnm , prt 0 var , doc (showString "::") , prt 0 type']) + TypeD con tyvars tydecl -> prPrec i 0 (concatD [doc (showString "type") , prt 0 con , prt 0 tyvars , doc (showString "=") , prt 0 tydecl]) + AscribeD var type' -> prPrec i 0 (concatD [prt 0 var , doc (showString "::") , prt 0 type']) + VarD var exp -> prPrec i 0 (concatD [prt 0 var , doc (showString "=") , prt 0 exp]) + ProcD var exps exp -> prPrec i 0 (concatD [prt 0 var , prt 0 exps , doc (showString "=") , prt 0 exp]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print AsSpec where + prt i e = case e of + AsAS con -> prPrec i 0 (concatD [doc (showString "as") , prt 0 con]) + EmptyAS -> prPrec i 0 (concatD []) + + +instance Print ExtNm where + prt i e = case e of + SomeNm str -> prPrec i 0 (concatD [prt 0 str]) + NoneNm -> prPrec i 0 (concatD []) + + +instance Print Exp where + prt i e = case e of + BlockE exps -> prPrec i 0 (concatD [doc (showString "do") , doc (showString "{") , prt 5 exps , doc (showString "}")]) + LetS exp0 exp -> prPrec i 5 (concatD [prt 4 exp0 , doc (showString "=") , prt 0 exp]) + LetE exp0 exp1 exp -> prPrec i 5 (concatD [doc (showString "let") , prt 4 exp0 , doc (showString "=") , prt 0 exp1 , doc (showString "in") , prt 0 exp]) + StoreE exp0 exp -> prPrec i 5 (concatD [prt 4 exp0 , doc (showString "<-") , prt 0 exp]) + CaseE exp casealts -> prPrec i 5 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 casealts , doc (showString "}")]) + BranchE branchalts -> prPrec i 5 (concatD [doc (showString "branch") , doc (showString "of") , doc (showString "{") , prt 0 branchalts , doc (showString "}")]) + BinOpE exp0 usym exp -> prPrec i 4 (concatD [prt 3 exp0 , prt 0 usym , prt 3 exp]) + AppE exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , prt 2 exp]) + UnOpE unop exp -> prPrec i 2 (concatD [prt 0 unop , prt 1 exp]) + IdxE exp0 exp -> prPrec i 1 (concatD [prt 1 exp0 , doc (showString "[") , prt 0 exp , doc (showString "]")]) + FldE exp field -> prPrec i 1 (concatD [prt 1 exp , doc (showString ".") , prt 0 field]) + ArrayE exps -> prPrec i 0 (concatD [doc (showString "Array") , doc (showString "[") , prt 0 exps , doc (showString "]")]) + RecordE fieldds -> prPrec i 0 (concatD [doc (showString "{") , prt 0 fieldds , doc (showString "}")]) + TupleE exps -> prPrec i 0 (concatD [doc (showString "(") , prt 0 exps , doc (showString ")")]) + AscribeE exp type' -> prPrec i 0 (concatD [doc (showString "(") , prt 0 exp , doc (showString "::") , prt 0 type' , doc (showString ")")]) + CountE count -> prPrec i 0 (concatD [prt 0 count]) + VarE var -> prPrec i 0 (concatD [prt 0 var]) + LitE lit -> prPrec i 0 (concatD [prt 0 lit]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + [x] -> (concatD [prt 0 x]) + [x] -> (concatD [prt 5 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + x:xs -> (concatD [prt 5 x , doc (showString ";") , prt 5 xs]) + +instance Print UnOp where + prt i e = case e of + Load -> prPrec i 0 (concatD [doc (showString "@")]) + + +instance Print CaseAlt where + prt i e = case e of + CaseAlt casepat exp -> prPrec i 0 (concatD [prt 0 casepat , doc (showString "->") , prt 0 exp]) + + prtList es = case es of + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print CasePat where + prt i e = case e of + ConP con var -> prPrec i 0 (concatD [prt 0 con , prt 0 var]) + LitP lit -> prPrec i 0 (concatD [prt 0 lit]) + VarP var -> prPrec i 0 (concatD [prt 0 var]) + + +instance Print BranchAlt where + prt i e = case e of + BranchAlt branchpat exp -> prPrec i 0 (concatD [doc (showString "|") , prt 0 branchpat , doc (showString "->") , prt 0 exp]) + + prtList es = case es of + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print BranchPat where + prt i e = case e of + BoolBP exp -> prPrec i 0 (concatD [prt 4 exp]) + DefaultBP -> prPrec i 0 (concatD []) + + +instance Print Type where + prt i e = case e of + TyFun type'0 type' -> prPrec i 0 (concatD [prt 2 type'0 , doc (showString "->") , prt 0 type']) + TyArray type'0 type' -> prPrec i 2 (concatD [doc (showString "Array") , prt 1 type'0 , prt 1 type']) + TyConstr con types -> prPrec i 2 (concatD [prt 0 con , prt 1 types]) + TyTuple types -> prPrec i 0 (concatD [doc (showString "(") , prt 0 types , doc (showString ")")]) + TyCount count -> prPrec i 0 (concatD [prt 0 count]) + TyVarT tyvar -> prPrec i 0 (concatD [prt 0 tyvar]) + TyConstr0 con -> prPrec i 0 (concatD [prt 0 con]) + + prtList es = case es of + [] -> (concatD []) + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + [x] -> (concatD [prt 1 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + x:xs -> (concatD [prt 1 x , prt 1 xs]) + +instance Print TyDecl where + prt i e = case e of + TyRecord fieldts -> prPrec i 0 (concatD [doc (showString "{") , prt 0 fieldts , doc (showString "}")]) + TyTagged concs -> prPrec i 0 (concatD [doc (showString "|") , prt 0 concs]) + TySyn type' -> prPrec i 0 (concatD [prt 0 type']) + + +instance Print ConC where + prt i e = case e of + ConC con types -> prPrec i 0 (concatD [prt 0 con , prt 0 types]) + + prtList es = case es of + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) + +instance Print FieldT where + prt i e = case e of + FieldT field type' -> prPrec i 0 (concatD [prt 0 field , doc (showString "::") , prt 0 type']) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print Lit where + prt i e = case e of + CharL c -> prPrec i 0 (concatD [prt 0 c]) + StringL str -> prPrec i 0 (concatD [prt 0 str]) + IntL number -> prPrec i 0 (concatD [prt 0 number]) + FracL frac -> prPrec i 0 (concatD [prt 0 frac]) + EnumL con -> prPrec i 0 (concatD [prt 0 con]) + + +instance Print FieldD where + prt i e = case e of + FieldD field exp -> prPrec i 0 (concatD [prt 0 field , doc (showString "=") , prt 0 exp]) + + prtList es = case es of + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print Var where + prt i e = case e of + Var lident -> prPrec i 0 (concatD [prt 0 lident]) + + +instance Print Con where + prt i e = case e of + Con uident -> prPrec i 0 (concatD [prt 0 uident]) + + +instance Print Modid where + prt i e = case e of + Modid uident -> prPrec i 0 (concatD [prt 0 uident]) + + +instance Print Field where + prt i e = case e of + Field lident -> prPrec i 0 (concatD [prt 0 lident]) + + +instance Print TyVar where + prt i e = case e of + VarTV lident -> prPrec i 0 (concatD [prt 0 lident]) + CntTV lident -> prPrec i 0 (concatD [doc (showString "#") , prt 0 lident]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + + diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,694 @@ +{-# 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 GHC.IO.Exception +import Language.Pec.Abs +import Language.Pec.ErrM +import Language.Pec.Layout +import Language.Pec.Par +import Language.Pec.Print +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 + } 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" + } &= summary summry &= program prog + +summry :: String +summry = prog ++ " v" ++ vers ++ ", " ++ copyright + +prog :: String +prog = "pec" + +copyright :: String +copyright = "(C) Brett Letner 2011" + +vers :: String +vers = "0.1" + +initSt :: Args -> St +initSt x = 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 = [] + } + +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 +-- , mains :: [FilePath] + } + +main :: IO () +main = do + args <- cmdArgs argsDesc + let fns = files 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 $ initSt args + when (modified st || rebuild st) $ writeFile mnFn $ H.prettyPrint $ + hMainModule (dropExtension fn) (visited st) (strings st) + let mnExe = new_ext ".exe" mnFn + my_system $ unwords ["ghc --make -o", mnExe, mnFn] -- fixme:check exit code + pwd <- getCurrentDirectory + my_system $ pwd ++ "/" ++ mnExe + let llFns = ["istrings_" ++ new_ext ".ll" fn] ++ (map (new_ext ".ll" . init) $ visited st) + let llBc = new_ext ".bc" llFn + my_system $ "cat " ++ unwords llFns ++ " | llvm-as > " ++ llBc + let llExe = new_ext ".exe" llFn + my_system $ unwords ["llvm-ld -disable-opt -o", llExe, llBc] -- array bug in llvm + when (not $ keep_tmps st) $ my_system $ unwords $ + [ "rm *.hi *.o", "*_.hs" -- fixme: clean up Cnts files + , mnExe, mnFn, llBc + ] ++ 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 fn = init n ++ ".pec" + 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 + +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 -> IO () +my_system s = do + putStrLn $ "system:" ++ s + ec <- system s + case ec of + ExitSuccess -> return () + ExitFailure i -> error $ "exiting(" ++ show i ++ ")" diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,45 @@ +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 diff --git a/Pec.cf b/Pec.cf new file mode 100644 --- /dev/null +++ b/Pec.cf @@ -0,0 +1,136 @@ +comment "//"; +comment "/*" "*/"; + +entrypoints Module; + +layout "where", "do", "of"; + +Module . Module ::= "module" Modid "exports" ExportDecl "where" "{" [TopDecl] "}"; + +ExpAllD . ExportDecl ::= "all"; +ExpListD . ExportDecl ::= "(" [Export] ")"; + +TypeEx . Export ::= Con Spec; +VarEx . Export ::= Var; + +Neither . Spec ::= ; +Decon . Spec ::= "(" "." ")"; +Both . Spec ::= "(" ".." ")"; + +ImportD . TopDecl ::= "import" Modid AsSpec; +ExternD . TopDecl ::= "extern" ExtNm Var "::" Type; +TypeD . TopDecl ::= "type" Con [TyVar] "=" TyDecl; +AscribeD . TopDecl ::= Var "::" Type; +VarD . TopDecl ::= Var "=" Exp; +ProcD . TopDecl ::= Var [Exp0] "=" Exp; + +AsAS . AsSpec ::= "as" Con ; +EmptyAS . AsSpec ::= ; + +SomeNm . ExtNm ::= String; +NoneNm . ExtNm ::= ; + +BlockE . Exp ::= "do" "{" [Exp5] "}"; +_ . Exp ::= Exp5; + +LetS . Exp5 ::= Exp4 "=" Exp; -- sugar which can only appear in a block and lhs only var +LetE . Exp5 ::= "let" Exp4 "=" Exp "in" Exp; +StoreE . Exp5 ::= Exp4 "<-" Exp; +CaseE . Exp5 ::= "case" Exp "of" "{" [CaseAlt] "}"; +BranchE . Exp5 ::= "branch" "of" "{" [BranchAlt] "}"; +_ . Exp5 ::= Exp4; + +BinOpE . Exp4 ::= Exp3 USym Exp3; +_ . Exp4 ::= Exp3; + +AppE . Exp3 ::= Exp3 Exp2; +_ . Exp3 ::= Exp2; + +UnOpE . Exp2 ::= UnOp Exp1; +_ . Exp2 ::= Exp1; + +IdxE . Exp1 ::= Exp1 "[" Exp "]"; +FldE . Exp1 ::= Exp1 "." Field; +_ . Exp1 ::= Exp0; + +ArrayE . Exp0 ::= "Array" "[" [Exp] "]"; +RecordE . Exp0 ::= "{" [FieldD] "}"; +TupleE . Exp0 ::= "(" [Exp] ")"; +AscribeE . Exp0 ::= "(" Exp "::" Type ")"; +CountE . Exp0 ::= Count; +VarE . Exp0 ::= Var; +LitE . Exp0 ::= Lit; + +Load . UnOp ::= "@"; + +CaseAlt . CaseAlt ::= CasePat "->" Exp; + +ConP . CasePat ::= Con Var; +LitP . CasePat ::= Lit; +VarP . CasePat ::= Var; + +BranchAlt . BranchAlt ::= "|" BranchPat "->" Exp; + +BoolBP . BranchPat ::= Exp4; +DefaultBP . BranchPat ::= ; + +TyFun . Type ::= Type2 "->" Type; +_ . Type ::= Type2; + +TyArray . Type2 ::= "Array" Type1 Type1; +TyConstr . Type2 ::= Con [Type1]; +_ . Type2 ::= Type1; + +_ . Type1 ::= Type0; + +TyTuple . Type0 ::= "(" [Type] ")"; +TyCount . Type0 ::= Count; +TyVarT . Type0 ::= TyVar; +TyConstr0 . Type0 ::= Con; + +TyRecord . TyDecl ::= "{" [FieldT] "}"; +TyTagged . TyDecl ::= "|" [ConC]; +TySyn . TyDecl ::= Type; + +ConC . ConC ::= Con [Type0]; + +FieldT . FieldT ::= Field "::" Type; + +CharL . Lit ::= Char; +StringL . Lit ::= String; +IntL . Lit ::= Number; +FracL . Lit ::= Frac; +EnumL . Lit ::= Con; + +FieldD . FieldD ::= Field "=" Exp; + +Var . Var ::= Lident; +Con . Con ::= Uident; +Modid . Modid ::= Uident; + +Field . Field ::= Lident; +VarTV . TyVar ::= Lident; +CntTV . TyVar ::= "#" Lident; + +token Frac ('-'? digit+ '.' digit+ ('e' '-'? digit+)?); + +token Uident (upper (letter | digit | '_')*); +token Lident ((lower | '_') (letter | digit | '_')*); +token USym (('!' | '#' | '$' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '\\' | '^' | '|' | '~')+); +token Number ('-'? digit+); +token Count ('#' digit+); + +separator Exp ","; +separator FieldT ","; +separator TyVar ""; +separator Type ","; +separator Export ","; +separator Type0 ""; +separator nonempty ConC "|"; +separator nonempty Exp0 ""; +separator nonempty FieldD ","; +separator nonempty Type1 ""; +separator TopDecl ";"; +separator nonempty CaseAlt ";"; +separator nonempty BranchAlt ";"; +separator nonempty Exp5 ";"; diff --git a/Pec/Base.hs b/Pec/Base.hs new file mode 100644 --- /dev/null +++ b/Pec/Base.hs @@ -0,0 +1,599 @@ +{-# 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" diff --git a/Pec/Makefile b/Pec/Makefile new file mode 100644 --- /dev/null +++ b/Pec/Makefile @@ -0,0 +1,2 @@ +clean : + rm -f *~ *.hi *.o diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,36 @@ +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, performant 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). + +Any feedback on the design and/or implementation of pec would be +greatly appreciated :) + +Thanks, +Brett +brettletner at gmail dot com diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,8 @@ +#! /usr/bin/env runhaskell + +-- The pec embedded compiler +-- Copyright 2011, Brett Letner + +import Distribution.Simple + +main = defaultMain diff --git a/THANKS b/THANKS new file mode 100644 --- /dev/null +++ b/THANKS @@ -0,0 +1,16 @@ +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! + diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,55 @@ +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 diff --git a/pec.cabal b/pec.cabal new file mode 100644 --- /dev/null +++ b/pec.cabal @@ -0,0 +1,46 @@ +Name: pec + +Version: 0.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, performant embedded applications. + +License: BSD3 + +License-file: LICENSE + +Author: Brett Letner + +Maintainer: Brett Letner + +Copyright: Brett letner 2011 + +Category: Language + +Build-type: Simple + +Extra-source-files: Pec.cf + +data-files: Makefile, FAQ, Pec/Makefile, DESIGN, test_cases/Makefile, test_cases/TestStack.pec, test_cases/Prelude.pec, test_cases/TestLoad.pec, test_cases/Stack.pec, test_cases/StrBuf.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 + + 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 diff --git a/test_cases/Makefile b/test_cases/Makefile new file mode 100644 --- /dev/null +++ b/test_cases/Makefile @@ -0,0 +1,16 @@ +.SUFFIXES : + +all : clean TestStack.exe TestStrBuf.exe TestPrims.exe TestTuple.exe TestVariant.exe TestArray.exe TestLoad.exe # T.exe + pec + pec --version + pec --help + +%.exe : %.pec + pec -k $< + ./$@ + +clean : + rm -f *.bc *.ll *.exe *.s *.out *~ *.tix + +vclean : clean + rm -f Cnt*.hs *.o *.hi *_.hs *_main.hs diff --git a/test_cases/Prelude.pec b/test_cases/Prelude.pec new file mode 100644 --- /dev/null +++ b/test_cases/Prelude.pec @@ -0,0 +1,287 @@ +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 Bool = | False | True +// enum type +// the "|" is used to specify "or" + +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 + +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 + +extern puts :: Ptr Char -> () +extern exit :: I32 -> () + +to_ordering :: I32 -> Ordering +to_ordering x = branch of + | x < 0 -> LT + | x > 0 -> GT + | -> EQ + +putCh :: Char -> () +putCh c = putchar c + +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 + +not :: Bool -> Bool +not x = if x False True + +putLn :: IString -> () +putLn x = puts (from_istring x) + +is_upper :: Char -> Bool +is_upper c = (c >= 'A') && (c <= 'Z') // operators don't have precedence, parens are required + +is_lower :: Char -> Bool +is_lower c = (c >= 'a') && (c <= 'z') + +is_digit :: Char -> Bool +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_upper :: Char -> Char +to_upper c = branch of + | is_lower c -> chr (ord c - 32) + | -> c + +// inline Haskell "library" DSL code + +>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 diff --git a/test_cases/Stack.pec b/test_cases/Stack.pec new file mode 100644 --- /dev/null +++ b/test_cases/Stack.pec @@ -0,0 +1,50 @@ +module Stack + +exports (Stack, stack, push, pop, is_empty, is_full) +// explicit export list + +where + +import Prelude + +type Stck #cnt a = { height :: W32, data :: Array cnt a } +// stacks are polymorphic in their size and what they contain + +type Stack #cnt a = Stck cnt a + +>type Stack cnt a = Stack_ cnt a +> +>stack_ :: (Count cnt, Typed cnt, Typed a) => Term (cnt -> Stack cnt a) +>stack_ = lam_ $ \_ -> lift $ do +> p <- eval $ alloca unused +> eval_ $ store (height_get p) (int 0) +> return $ load p +> +>push_ :: (Count cnt, Typed cnt, Typed a) => +> Term (a -> Ptr (Stack cnt a) -> Bool_) +>push_ = lam2_ $ \a (p :: Term (Ptr (Stack cnt a))) -> +> app3 if_ (app is_full_ p) +> false_ +> (lift (do i <- eval $ load (height_get p) +> evalv $ store (idx (data_get p) (cast i)) a +> evalv $ store (height_get p) (add i (int 1)) +> return true_ +> )) +> +>pop_ :: (Count cnt, Typed cnt, Typed a) => +> Term (Ptr (Stack cnt a) -> Maybe_ a) +>pop_ = lam_ $ \p -> app3 if_ (app is_empty_ p) +> nothing_ +> (lift (do i <- eval $ sub (load (height_get p)) (int 1) +> evalv $ store (height_get p) i +> return $ app just_ (load (idx (data_get p) (cast i))) +> )) +> +>is_empty_ :: (Count cnt, Typed cnt, Typed a) => +> Term (Ptr (Stack cnt a) -> Bool_) +>is_empty_ = lam_ $ \p -> eq (load (height_get p)) (int 0) +> +>is_full_ :: (Count cnt, Typed cnt, Typed a) => +> Term (Ptr (Stack cnt a) -> Bool_) +>is_full_ = lam_ $ \(p :: Term (Ptr (Stack cnt a))) -> +> eq (load (height_get p)) (int $ countof (unused :: cnt)) diff --git a/test_cases/StrBuf.pec b/test_cases/StrBuf.pec new file mode 100644 --- /dev/null +++ b/test_cases/StrBuf.pec @@ -0,0 +1,48 @@ +module StrBuf exports all + +where + +import Prelude + +type StrBuf #cnt = | StrBuf (Array (SuccCnt cnt) Char) + +extern "strcmp" c_strcmp :: Ptr Char -> Ptr Char -> I32 +extern "strlen" c_strlen :: Ptr Char -> W32 +extern "strncpy" c_strncpy :: Ptr Char -> Ptr Char -> I32 -> Ptr Char +// a different name can be used for the C call if necessary + +>type StrBuf a = StrBuf_ a +> +>strbuf_ :: (Count cnt, Typed cnt) => Term (cnt -> StrBuf cnt) +>strbuf_ = lam_ $ \(a :: Term cnt) -> +> cast (app2 array_ (unused :: Term (SuccCnt cnt)) (char '\0')) +> +>from_strbuf_ :: Count cnt => Term (Ptr (StrBuf cnt) -> Ptr Char) +>from_strbuf_ = lam_ bitcast +> +>put_ :: Count cnt => Term (Ptr (StrBuf cnt) -> ()) +>put_ = lam_ $ \p -> app puts_ (app from_strbuf_ p) +> +>strlen_ :: Count cnt => Term (Ptr (StrBuf cnt) -> W32) +>strlen_ = lam_ $ \x -> app c_strlen_ (app from_strbuf_ x) +> +>strcmp_ :: (Count a, Count b) => +> Term (Ptr (StrBuf a) -> Ptr (StrBuf b) -> Ordering_) +>strcmp_ = lam2_ $ \x y -> +> app to_ordering_ (app2 c_strcmp_ (app from_strbuf_ x) (app from_strbuf_ y)) +> +>to_strbuf_ :: Count cnt => Term (IString -> Ptr (StrBuf cnt) -> Bool_) +>to_strbuf_ = lam2_ $ \x y -> app2 strncpy (app from_istring_ x) y +> +>strcpy_ :: (Count a, Count b) => +> Term (Ptr (StrBuf a) -> Ptr (StrBuf b) -> Bool_) +>strcpy_ = lam2_ $ \x y -> app2 strncpy (app from_strbuf_ x) y +> +>strncpy :: Count cnt => Term (Ptr Char -> Ptr (StrBuf cnt) -> Bool_) +>strncpy = lam2_ $ \x (y :: Term (Ptr (StrBuf cnt))) -> Lift $ do +> let n = countof (unused :: cnt) +> evalv $ app3 c_strncpy_ (app from_strbuf_ y) x (int $ succ n) +> c <- eval $ idx (app unwrap_ptr_ y) (int n) +> return $ app3 if_ (load c `eq` char '\0') +> true_ +> (lift (eval (store c (char '\0')) >> return false_)) diff --git a/test_cases/TestArray.pec b/test_cases/TestArray.pec new file mode 100644 --- /dev/null +++ b/test_cases/TestArray.pec @@ -0,0 +1,69 @@ +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" :: ()) diff --git a/test_cases/TestLoad.pec b/test_cases/TestLoad.pec new file mode 100644 --- /dev/null +++ b/test_cases/TestLoad.pec @@ -0,0 +1,13 @@ +module TestLoad exports all + +where + +import Prelude + +main :: () -> I32 +main () = do + p = new 'a' + assert (@p == 'a') + putCh @p + putCh '\n' + 0 diff --git a/test_cases/TestPrims.pec b/test_cases/TestPrims.pec new file mode 100644 --- /dev/null +++ b/test_cases/TestPrims.pec @@ -0,0 +1,260 @@ +module TestPrims // module declaration + +exports all // export declaration + +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) + +gSideEffect :: Bool +gSideEffect = do + putLn "side effect" // print an IString to the screen + True +// pec is impure. +// This definition will get 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 has type function of () to W32 +// where () is the type 'unit' (similar to void in C) +main () = do // unit pattern match + putLn "starting test..." + testChar () // procedure call. calls are made using juxtaposition like in Haskell, not tupling like in C + testI32 () + testW16 () + testBool () + testIString () + testDouble () + putLn "...test complete" + 0 + +testI32 :: () -> () +testI32 () = do + putLn "testI32" + assert (gi32 == 3) // assert is just a library function + assert ((0 :: I32) == 0) // type ascription + 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 (gi32 == 3) + putLn "done" + +testW16 :: () -> () +testW16 () = do + putLn "testW16" + assert ((0 :: W16) == 0) + x = (4 :: W16) // name binding +// 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 + 4 -> assert True // pattern on the left, expression on the right + _ -> assert False // default + + case (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. + 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 + 3 -> assert False + x -> assert (x == 12) + + assert (gw16 == 12) + assert (gw16_2 == 13) + assert ((1 << 1) == (2 :: W16)) // left shift operator + +// 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 + + putLn "done" + +testBool :: () -> () +testBool () = do + putLn "testBool" + assert True + assert (not False) + assert (True == True) + assert (gbool == True) + assert gSideEffect // will output to the screen + assert gSideEffect // will also output to the screen + x = gSideEffect // will output to the screen +// x is evaluated immediately + assert x // won't output anything + assert x // won't output anything + putLn "done" + +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 + "bye" -> assert False + "hi" -> assert True + s -> do // default pattern match, so that we can use the case 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 + "blah" -> assert (s == "blah") + _ -> assert False + putLn "done" + +type MyChar a = Char // polymorphic type + +testChar :: () -> () +testChar () = do // character literals + putLn "testChar" + assert (is_lower 'a') + assert (is_upper 'A') + assert (gchar == 'a') + putCh 't' + + if ('m' == 'm') (putCh 't') (putCh 'f') + + case 'm' of + 'n' -> putCh 'n' + 'm' -> putCh 't' + v -> putCh v + + case 't' of + 'm' -> putCh 'm' + 'n' -> putCh 'n' + v -> putCh v + + 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 + 'm' -> putCh 'm' + 'n' -> putCh 'n' + v -> putCh v + + p = new 't' + + putCh @p + + if (@p == 'm') + (putCh 'f') + (putCh 't') + + case @p of + 'm' -> putCh 'm' + 'n' -> putCh 'n' + v -> do + putCh @p + putCh v + + p <- 'T' + + putCh @p + + assert (@p == 'T') + + putCh @p + + p <- x + + putCh @p + + p <- @p + + putCh @p + + p <- case 'l' of + 'l' -> 't' + 'n' -> 'n' + _ -> 'a' + + putCh @p + + p <- getT () + + putCh @p + + let c = ('a' :: MyChar W32) in putCh c // let expression + + (v) = 'c' // parens used for grouping + putCh v + assert (is_lower v) + putCh (to_upper v) + putCh (to_lower (to_upper @p)) + assert (is_upper (to_upper v)) + assert (funptr is_lower 'c') // making a call using a function pointer + assert (funptr is_upper 'C') // again, but with different arguments + w = funptr2 to_lower 'A' + x = funptr2 to_upper 'a' + putCh w + putCh x + assert (is_lower w) + assert (is_upper x) + putCh '\n' + 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 + +funptr2 :: (Char -> Char) -> Char -> Char +funptr2 f c = f c diff --git a/test_cases/TestStack.pec b/test_cases/TestStack.pec new file mode 100644 --- /dev/null +++ b/test_cases/TestStack.pec @@ -0,0 +1,39 @@ +module TestStack exports all + +where + +// polymorphic Stack implementation + +import Prelude +import Stack + +main :: () -> W32 +main () = do + putLn "test Stack" + p = new (stack #3) // stacks must be given a size + case new (pop p) of + Nothing -> assert True + Just _ -> assert False + assert (push 'a' p) + case new (pop p) of + Nothing -> assert False + Just c -> do + putCh @c + assert (@c == 'a') + assert (is_empty p) + assert (push 'a' p) + assert (push 'b' p) + assert (push 'c' p) + assert (is_full p) + assert (not (push 'd' p)) + mc = new (pop p) + case mc of + Nothing -> assert False + Just c -> do + putCh @c + assert (@c == 'c') + mc <- pop p + mc <- pop p + assert (is_empty p) + putLn "done" + 0 diff --git a/test_cases/TestStrBuf.pec b/test_cases/TestStrBuf.pec new file mode 100644 --- /dev/null +++ b/test_cases/TestStrBuf.pec @@ -0,0 +1,46 @@ +module TestStrBuf exports all + +where + +import Prelude +import StrBuf + +// String buffers, like char sbuf[N] in C except we don't have to worry about a missing null terminator + +main :: () -> W32 +main () = do + putLn "test StrBuf" + p = new (strbuf #5) // declaring an empty string buffer requires a singleton "Count" value + assert (strlen p == 0) + put p + assert (to_strbuf "BL" p) // to_strbuf returns True if all the characters were copied + put p + assert (strlen p == 2) + assert (to_strbuf "Brett" p) + assert (strlen p == 5) + put p + 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) + assert (to_strbuf "Letner" q) + assert (strlen q == 6) + put q + case 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 + EQ -> assert True + _ -> assert False + to_strbuf "foo" p + put p + put q + strcpy p q + put q + assert (strcmp p q == EQ) + putLn "done" + 0 diff --git a/test_cases/TestTuple.pec b/test_cases/TestTuple.pec new file mode 100644 --- /dev/null +++ b/test_cases/TestTuple.pec @@ -0,0 +1,119 @@ +module TestTuple exports all + +where + +import Prelude + +// () is a tuple with no elements. +// it gets compiled as "void" in the LLVM code +main :: () -> W32 +main () = do + testUnit () + testPair () + testTuple () + testRecord () + 0 + +testUnit :: () -> () +testUnit () = do + putLn "testUnit" + putLn "done" + +pairf :: Ptr (Char, Bool) -> () // pairf takes a pointer to a tuple containing a Char and a Bool and returns () +pairf (a,b) = do // tuple pattern match on left hand side + putCh @a + assert (@a == 'a') + assert @b + +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 + assert @b + + c <- 'b' + b <- False + putCh @c + putCh @p.fst + putCh @(fst p) + assert (not @b) + + p.fst <- 'c' + p.snd <- True + putCh @c + putCh @p.fst + putCh @(fst p) + assert @p.snd + assert @b + pairf (new ('a',True)) + putLn "done" + +tuplef :: Ptr (Bool, Char, W32) -> () +// a triple of Bool, Char, and W32 +// n-ary tuples in pec are syntactic sugar for pairs, so +// this is exactly the same as (Bool, (Char, W32)) +tuplef p = do + (x,y,z) = p // sugar for (x,(y,z)) + assert @x + putCh @y + assert (@y == 'c') + assert (@z == 7) + +testTuple :: () -> () +testTuple () = do + putLn "testTuple" + t3 = ('c',True,"asdf") // sugar for ('c', (True, "asdf")) + p = new t3 + putCh @p.fst + assert @p.snd.fst // record syntax + putLn @p.snd.snd + (x,y,z) = p + putLn @z + assert @y + (a,(b,c)) = p + putLn @c + assert @b + tuplef (new (True, 'c', 7)) + putLn "done" + +type Person = // the standard record example + { name :: IString + , middle_initial :: Char + , city :: IString + , zipcode :: W32 } +// order of elements doesn't matter, so this is exactly the same as +// type Person = +// { zipcode :: W32 +// , city :: IString +// , middle_initial :: Char +// , name :: IString +// } + +type Stuff = { stuff :: Char } + +testRecord :: () -> () +testRecord () = do + putLn "testRecord" + x = { stuff = 'a' } + p = new x + assert (@p.stuff == 'a') + putCh @p.stuff + p.stuff <- 'b' + 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 :) + + q = new y + putLn @q.name + putLn @q.city + assert (@q.zipcode == 90210) + q.city <- "BC" + assert (@q.city == "BC") + putLn "done" diff --git a/test_cases/TestVariant.pec b/test_cases/TestVariant.pec new file mode 100644 --- /dev/null +++ b/test_cases/TestVariant.pec @@ -0,0 +1,140 @@ +module TestVariant exports all + +where + +import Prelude + +main :: () -> W32 +main () = do + testEnum () + testNewtype () + testNewtypePoly () + testVariant () + testUnit () + 0 + +type Color = | Red | Blue | Green // the standard enum example + +unColor :: Color -> W32 +unColor c = case c of + Red -> 0 + Blue -> 1 + Green -> 2 + +sColor :: Color -> IString +sColor c = case c of // case on enums is by value + Red -> "Red" + Blue -> "Blue" + Green -> "Green" + +type Unit = | Unit // singleton type, isomorphic to () + +unitf :: () -> Unit +unitf () = Unit + +unita :: Unit -> () +unita _ = () // todo(?): unita Unit = () + +testUnit :: () -> () +testUnit () = do + putLn "testunit" + x = Unit // singleton types are compiled into "void" in LLVM + unita x + unitf () + unita Unit + putLn "done" + +testEnum :: () -> () +testEnum () = do + putLn "testEnum" + assert (Red == Red) + x = Green // enum types are compiled into unsigned ints in LLVM + putLn (sColor x) + assert (Green == x) + assert (x == Green) + assert (x != Blue) + p = new Blue + assert (@p == Blue) + putLn (sColor @p) + p <- Red + assert (@p != Blue) + putLn (sColor @p) + p <- x + putLn (sColor @p) + assert (@p == Green) + assert (unColor @p == 2) + assert (unColor Blue == 1) + case Red of + Green -> assert False + Red -> assert True + color -> assert (color != Blue) + case x of + Green -> assert True + Red -> assert False + Blue -> assert False + 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 + +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) + x = M 12 + assert (x == M 12) + p = new (M 7) + assert (@p != M 12) + 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 + p <- M 1 + i = unwrap @p + assert (i == 1) + putLn "done" + +testNewtypePoly :: () -> () +testNewtypePoly () = do + putLn "testNewtypePoly" + x = My 'c' + p = new x + assert (unwrap @p == 'c') + q = new (My True) + assert (unwrap @q) + putLn "done" + +testVariant :: () -> () +testVariant () = do + putLn "testVariant" + p = new (Left False) + p <- Right 'c' // p :: Ptr (Either Bool Char) +// variants must be accessed via a pointer + case p of + Left a -> do + assert @a + Right b -> do // b :: Ptr Char, not Char + putCh @b + assert (@b == 'c') + p <- Left True // store the value "Left True" in p + case p of + Left a -> assert @a + Right b -> do + putCh @b + assert False + q = new Nothing + case q of + Nothing -> assert True + Just _ -> assert False + q <- Just True + case q of + Just b -> assert @b + _ -> assert False + putLn "done"