diff --git a/CHANGELOG b/CHANGELOG deleted file mode 100644 --- a/CHANGELOG +++ /dev/null @@ -1,30 +0,0 @@ -New in 0.1.6 ------------- - -* Changed dependent pair syntax to <| x, y |> so that << and >> can be - integer shift operators. -* Removed '#' as type of types (must use 'Set' now). -* searchcontext tactic -* equalities.idr in the library -* codata keyword -* proof and tryproof keywords for invoking a decision procedure in a - term -* Syntactic sugar for Cons lists -* Lots of smaller changes and bug fixes - -New in 0.1.5 ------------- - -* Changed '#' to Set for the type of types - - old syntax works, but is deprecated and will be removed soon. -* 'syntax' definitions -* %spec works in pattern clauses as well as CAFs -* Added 'Proof' type for marking computationally irrelevant terms. -* Added List permutation proofs to the library (perm.idr) -* Various new functions in the library. -* Lots of bug fixes - -New in 0.1.4 ------------- - -* Namespaces diff --git a/Idris/AbsSyntax.lhs b/Idris/AbsSyntax.lhs deleted file mode 100644 --- a/Idris/AbsSyntax.lhs +++ /dev/null @@ -1,1496 +0,0 @@ -> {-# OPTIONS_GHC -fglasgow-exts #-} - -> module Idris.AbsSyntax(module Idris.AbsSyntax, -> module Idris.Context) where - -> import Control.Monad -> import Control.Monad.State -> import qualified Data.Map as Map -> import Debug.Trace -> import Data.Typeable -> import Data.Maybe -> import Data.List -> import Char - -> import Ivor.TT -> import Ivor.Primitives - -> import Idris.Context - -> data Result r = Success r -> | Failure String String Int -> deriving (Show, Eq) -> -> instance Monad Result where -> (Success r) >>= k = k r -> (Failure err fn line) >>= k = Failure err fn line -> return = Success -> fail s = Failure s "(no file)" 0 -> -> instance MonadPlus Result where -> mzero = Failure "Error" "(no file)" 0 -> mplus (Success x) _ = (Success x) -> mplus (Failure _ _ _) y = y -> - -A program is a collection of datatype and function definitions. -We store everything directly as a 'ViewTerm' from Ivor. - -> data Decl = DataDecl Datatype | Fwd Id RawTerm [CGFlag] -> | PInclude FilePath -> | Fun Function [CGFlag] | TermDef Id RawTerm [CGFlag] | Constructor -> | Prf Proof Bool -- 'True' means proof is allowed to fail -> | LatexDefs [(Id,String)] -> | Using [(Id, RawTerm)] [Decl] -- default implicit args -> | Params [(Id, RawTerm)] [Decl] -- default implicit args -> | DoUsing Id Id [Decl] -- bind and return names -> | Idiom Id Id [Decl] -- pure and ap names -> | Namespace Id [Decl] -- bind and return names -> | CLib String | CInclude String -> | Fixity String Fixity Int -> | Transform RawTerm RawTerm -> | SynDef Id [Id] RawTerm -> | Freeze String Int [Id] Id -> deriving Show - -Flags for controlling compilation. In particular, some functions exist only -run compile-time function generation, so we never want to generate code -(e.g. generating foreign functiond defs). -Also, some functions should be evaluated completely before code generation -(e.g. for statically knowing the C function to compile) -Functions may be exported to C, if they have a simple type (no polymorphism, no dependencies). - -> data CGFlag = NoCG | CGEval | CExport String | Inline | CGSpec [(Id, Int)] -> | Vis Visibility -> deriving (Show, Eq) - -Public: Name, type and definition visible globally -Abstract: Only name and type visible (i.e. no constructors, or definition) - outside the namespace. -Private: Nothing visible outside the namespace. - -> data Visibility = Public | Private | Abstract -> deriving (Show, Eq) - -User defined operators have associativity and precedence - -> data Fixity = LeftAssoc | RightAssoc | NonAssoc -> deriving (Show, Eq, Enum) - -> type Fixities = [(String, (Fixity, Int))] - -> data UserOps = UO { fixityDecls :: Fixities, -> transforms :: [(ViewTerm, ViewTerm)], -> frozen :: [Id], -> syndefs :: Ctxt Syntax } -> deriving Show - -Function types and clauses are given separately, so we'll parse them -separately then collect them together into a list of Decls - -A FunClauseP is a clause which is probably the wrong type, but instructs -the system to insert a hole for a proof that turns it into the right type. - -> data ParseDecl = RealDecl Decl -> | FunType Id RawTerm [CGFlag] String Int -> | FunClause RawTerm [RawTerm] RawTerm [CGFlag] -> | FunClauseP RawTerm [RawTerm] RawTerm Id -> | WithClause RawTerm [RawTerm] Bool RawTerm [ParseDecl] -> | ProofScript Id [ITactic] -> | PUsing [(Id,RawTerm)] [ParseDecl] -> | PParams [(Id, RawTerm)] [ParseDecl] -> | PDoUsing (Id, Id) [ParseDecl] -> | PIdiom (Id, Id) [ParseDecl] -> | PNamespace Id [ParseDecl] -> deriving Show - -> collectDecls :: [ParseDecl] -> Result [Decl] -> collectDecls pds = cds [] [] pds -> where cds rds fwds ((RealDecl d):ds) = cds (d:rds) fwds ds -> cds rds fwds ((FunType n t fl file line):ds) -> = getClauses RPlaceholder rds fwds n (t, file, line) fl [] ds -> cds rds fwds ((FunClause (RVar f l n _) [] ret fl):ds) -> = cds ((TermDef n ret fl):rds) fwds ds -> cds rds fwds ds@((FunClause app [] ret fl):_) -> = case getFnName app of -> Just (n, file, line) -> -> case (lookup n fwds) of -> Nothing -> fail $ "No type declaration for " ++ show n -> Just (ty,fl) -> getClauses app rds fwds n (ty, file, line) fl [] ds -> _ -> fail $ "Invalid pattern clause" -> cds rds fwds ((ProofScript n prf):ds) -> = case lookup n fwds of -> Nothing -> -> cds ((Prf (Proof n Nothing prf) False):rds) fwds ds -> Just (ty, fl) -> -> cds ((Prf (Proof n (Just ty) prf) False):rds) fwds ds -> cds rds fwds ((PUsing uses pds):ds) = -> case (cds [] [] pds) of -> Success d -> -> cds ((Using uses d):rds) fwds ds -> failure -> failure -> cds rds fwds ((PParams params pds):ds) = -> case (cds [] [] pds) of -> Success d -> -> cds ((Params params d):rds) fwds ds -> failure -> failure -> cds rds fwds ((PDoUsing (ub,ur) pds):ds) = -> case (cds [] [] pds) of -> Success d -> -> cds ((DoUsing ub ur d):rds) fwds ds -> failure -> failure -> cds rds fwds ((PNamespace ns pds):ds) = -> case (cds [] [] pds) of -> Success d -> -> cds ((Namespace ns d):rds) fwds ds -> failure -> failure -> cds rds fwds ((PIdiom (up,ua) pds):ds) = -> case (cds [] [] pds) of -> Success d -> -> cds ((Idiom up ua d):rds) fwds ds -> failure -> failure -> cds rds fwds (d:ds) = fail $ "Invalid declaration: " ++ show d -> cds rds fwds [] = return (reverse rds) - - -> getClauses parent rds fwds n t fl clauses ((FunClause RPlaceholder [with] ret fl'):ds) -> = getClauses parent rds fwds n t fl clauses ((FunClause parent [with] ret fl'):ds) -> getClauses parent rds fwds n t fl clauses ((FunClause pat withs ret fl'):ds) -> | Just (f,l) <- isnm n (getFn pat) -> = getClauses parent rds fwds n t fl ((n, RawClause (mkApp f l pat withs) ret):clauses) ds -> getClauses parent rds fwds n t fl clauses ((FunClauseP RPlaceholder [with] ret mv):ds) -> = getClauses parent rds fwds n t fl clauses ((FunClauseP parent [with] ret mv):ds) -> getClauses parent rds fwds n t fl clauses ((FunClauseP pat withs ret mv):ds) -> | Just (f,l) <- isnm n (getFn pat) -> = getClauses parent rds fwds n t fl -> ((n, RawClause (mkApp f l pat withs) (mkhret mv ret)):clauses) ds -> getClauses parent rds fwds n t fl clauses ((WithClause RPlaceholder [with] prf ret fl'):ds) -> = getClauses parent rds fwds n t fl clauses ((WithClause parent [with] prf ret fl'):ds) -> getClauses parent rds fwds n t fl clauses ((WithClause pat withs prf scr defs):ds) -> | Just (f,l) <- isnm n (getFn pat) -> = do wcl <- collectWiths (mkApp f l pat withs) rds fwds n t fl defs -> getClauses parent rds fwds n t fl -> ((n, RawWithClause (mkApp f l pat withs) prf scr wcl):clauses) ds -> getClauses parent rds fwds n (t, _, _) fl [] ds -> = cds ((Fwd n t fl):rds) ((n,(t,fl)):fwds) ds -> getClauses parent rds fwds n (t,file,line) fl clauses ds = -> cds ((Fun (Function n t (reverse clauses) file line) fl):rds) fwds ds - -> isnm n (RVar f l nm _) | nm == n = Just (f,l) -> isnm _ _ = Nothing - -> collectWiths parent rds fwds n t fl cs = -> do cls <- getClauses parent [] [] n t fl [] cs -> case cls of -> [Fun (Function _ _ cl _ _) _] -> return (map snd cl) -> _ -> fail $ "Invalid with clause for " ++ show n - - collectWiths rds fwds n t fl ((FunClause pat ex rhs []):cs) = - | (RVar n) == getFn pat - = RawClause (mkApp pat withs) - -> mkhret mv v = RBind (UN "value") (RLet v RPlaceholder) -> (RMetavar mv) - -> data Datatype = Datatype { -> tyId :: Id, -> tyType :: RawTerm, -> tyConstructors :: [(Id, RawTerm)], -> tyImplicits :: [(Id, RawTerm)], -> tyOpts :: [TyOpt], -> tyFile :: String, -> tyLine :: Int -> } -> | Latatype { tyId :: Id, -> tyType :: RawTerm, -> tyFile :: String, -> tyLine :: Int -> } -- forward declaration -> deriving Show - -> data TyOpt = NoElim | Collapsible | Codata -> deriving (Show, Eq, Enum) - -> tyHasElim dt = not (elem NoElim (tyOpts dt)) -> collapsible dt = elem Collapsible (tyOpts dt) - -> data Function = Function { -> funId :: Id, -> funType :: RawTerm, -> funClauses :: [(Id, RawClause)], -> funFile :: String, -> funLine :: Int -> } -> deriving Show - -> data Proof = Proof { -> proofId :: Id, -> proofType :: Maybe RawTerm, -> proofScript :: [ITactic] -> } -> deriving Show - -> getId :: Decl -> Id -> getId (Fun f _) = funId f -> getId (DataDecl d) = tyId d -> getId (TermDef n tm _) = n - -Raw terms, as written by the programmer with no implicit arguments added. - -> data RawTerm = RVar String Int Id NameType -> | RVars String Int [Id] -> | RExpVar String Int Id -- variable with all explicit args -> | RApp String Int RawTerm RawTerm -> | RAppImp String Int Id RawTerm RawTerm -- Name the argument we make explicit -> | RBind Id RBinder RawTerm -> | RConst String Int Constant -> | RPlaceholder -> | RMetavar Id -> | RMetavarPrf Id [ITactic] Bool -- Bool for if proof is allowed to fail -> | RInfix String Int Op RawTerm RawTerm -> | RUserInfix String Int Bool String RawTerm RawTerm -> | RDo [Do] -> | RReturn String Int -> | RIdiom RawTerm -> | RPure RawTerm -- a term to apply normally inside idiom brackets -> | RRefl -> | RError String Int String -- Hackety. Found an error in processing, report when you can. -> deriving (Show, Eq) - -> data RBinder = Pi Plicit [ArgOpt] RawTerm -> | Lam RawTerm -> | RLet RawTerm RawTerm -> deriving (Show, Eq) - -> data Plicit = Im | Ex -> deriving (Show, Eq, Enum) - -> data ArgOpt = Lazy | Static -> deriving (Show, Eq, Enum) - -> data Do = DoBinding String Int Id RawTerm RawTerm -> | DoLet String Int Id RawTerm RawTerm -> | DoExp String Int RawTerm -> deriving (Show, Eq) - -> data ITactic = Intro [Id] -> | Refine Id -> | Exists RawTerm -> | Generalise RawTerm -> | ReflP -> | Induction RawTerm -> | Fill RawTerm -> | Trivial -> | SimpleSearch -> | Case RawTerm -> | Rewrite Bool Bool RawTerm -> | Unfold Id -> | Compute -> | Equiv RawTerm -> | Believe RawTerm -> | Use RawTerm -> | Decide RawTerm -> | Undo -> | Abandon -> | ProofTerm -> | RunTactic RawTerm -- tactic computed from lib/tactics.idr -> | Qed -> deriving (Show, Eq) - -> getArgOpt :: ArgOpt -> RawTerm -> [Int] -> getArgOpt ao tm = gl' 0 tm -> where gl' i (RBind n (Pi _ opts _) sc) -> | ao `elem` opts = i:(gl' (i+1) sc) -> gl' i (RBind n (Pi Ex _ _) sc) = gl' (i+1) sc -> gl' i (RBind n (Pi Im _ _) sc) = gl' i sc -> gl' i x = [] - -> getLazy = getArgOpt Lazy -> getStatic = getArgOpt Static - -> mkLazy :: ViewTerm -> ViewTerm -> mkLazy t = App (App (Name Unknown (name "__lazy")) Placeholder) t - -> getFileLine :: RawTerm -> (String, Int) -> getFileLine (RApp f l _ _) = (f, l) -> getFileLine (RAppImp f l _ _ _) = (f, l) -> getFileLine (RVar f l _ _) = (f, l) -> getFileLine (RExpVar f l _) = (f, l) -> getFileLine (RInfix f l _ _ _) = (f, l) -> getFileLine (RUserInfix f l _ _ _ _) = (f, l) -> getFileLine (RConst f l _) = (f, l) -> getFileLine (RBind _ (Pi _ _ ty) _) = getFileLine ty -> getFileLine (RBind _ (Lam ty) _) = getFileLine ty -> getFileLine _ = ("(unknown)", 0) - -> getFn :: RawTerm -> RawTerm -> getFn (RApp _ _ f a) = getFn f -> getFn (RAppImp _ _ _ f a) = getFn f -> getFn f = f - -> getArgTypes :: RawTerm -> [(Id,RawTerm)] -> getArgTypes tm = gat tm [] where -> gat (RBind n (Pi _ _ ty) sc) acc = gat sc ((n,ty):acc) -> gat sc acc = reverse acc - -> getRetType :: RawTerm -> RawTerm -> getRetType (RBind n (Pi _ _ ty) sc) = getRetType sc -> getRetType x = x - -> getFnName f = case getFn f of -> (RVar f l n _) -> Just (n,f,l) -> _ -> Nothing - -> getRawArgs :: RawTerm -> [RawTerm] -> getRawArgs x = args [] x -> where args acc (RApp _ _ f a) = args (a:acc) f -> args acc (RAppImp _ _ _ f a) = args (a:acc) f -> args acc f = acc - -> getExplicitArgs :: RawTerm -> [RawTerm] -> getExplicitArgs x = args [] x -> where args acc (RApp _ _ f a) = args (a:acc) f -> args acc (RAppImp _ _ _ f a) = args acc f -> args [] (RInfix _ _ _ x y) = [x,y] -> args [] (RUserInfix _ _ _ _ x y) = [x,y] -> args acc f = acc - -Binders; Pi (either implicit or explicitly written), Lambda and Let with -value. - -> data Constant = Num Int -> | Str String -> | Bo Bool -> | Ch Char -> | Fl Double -> | TYPE -> | LTYPE -> | StringType -> | IntType -> | FloatType -> | CharType -> | PtrType -> | Builtin String -- builtin type, eg Handle or Lock -> deriving (Eq, Ord) - -> instance ViewConst Char where -> typeof x = (name "Char") - -> instance Show Constant where -> show (Num i) = show i -> show (Str s) = show s -> show (Bo b) = show b -> show (Ch c) = show c -> show (Fl d) = show d -> show TYPE = "Set" -> show LTYPE = "LSet" -> show IntType = "Int" -> show FloatType = "Float" -> show CharType = "Char" -> show StringType = "String" -> show PtrType = "Ptr" -> show (Builtin s) = s - -Operators, more precisely, are built-in functions on primitive types which both the -typechecker and compiler need to know how to run. First we have the usual set of infix -operators (plus John Major equality): - -> data Op = Plus | Minus | Times | Divide | Modulo | Concat | JMEq -> | FPlus | FMinus | FTimes | FDivide -> | OpEq | OpLT | OpLEq | OpGT | OpGEq -> | OpFEq | OpFLT | OpFLEq | OpFGT | OpFGEq -> | OpOr | OpAnd | ShL | ShR - -Then built-in functions for coercing between types - -> | ToString | ToInt -> | FloatToString | StringToFloat -> | IntToChar | CharToInt - -Finally some primitive operations on primitive types. - -> | StringLength | StringGetIndex | StringSubstr -> | StringHead | StringTail | StringCons | StringRev -> | StringFind | StringSub -> deriving (Eq, Enum) - -> allOps = [Plus,Minus,Times,Divide,Modulo,FPlus,FMinus,FTimes,FDivide, -> Concat,ShL,ShR,JMEq,OpEq,OpLT,OpLEq,OpGT,OpGEq, -> OpFEq,OpFLT,OpFLEq,OpFGT,OpFGEq] - -> instance Show Op where -> show Plus = "+" -> show Minus = "-" -> show Times = "*" -> show Divide = "/" -> show Modulo = "%" -> show FPlus = "+." -> show FMinus = "-." -> show FTimes = "*." -> show FDivide = "/." -> show Concat = "++" -> show JMEq = "=" -> show OpEq = "==" -> show OpLT = "<" -> show OpLEq = "<=" -> show OpGT = ">" -> show OpGEq = ">=" -> show OpFEq = "==." -> show OpFLT = "<." -> show OpFLEq = "<=." -> show OpFGT = ">." -> show OpFGEq = ">=." -> show OpOr = "||" -> show OpAnd = "&&" -> show ShL = "<<" -> show ShR = ">>" - -> opFn Plus = (name "__addInt") -> opFn Minus = (name "__subInt") -> opFn Times = (name "__mulInt") -> opFn Divide = (name "__divInt") -> opFn Modulo = (name "__modInt") -> opFn FPlus = (name "__addFloat") -> opFn FMinus = (name "__subFloat") -> opFn FTimes = (name "__mulFloat") -> opFn FDivide = (name "__divFloat") -> opFn Concat = (name "__concat") -> opFn JMEq = (name "Eq") -> opFn OpEq = (name "__eq") -> opFn OpLT = (name "__intlt") -> opFn OpLEq = (name "__intleq") -> opFn OpGT = (name "__intgt") -> opFn OpGEq = (name "__intgeq") -> opFn OpFEq = (name "__feq") -> opFn OpFLT = (name "__floatlt") -> opFn OpFLEq = (name "__floatleq") -> opFn OpFGT = (name "__floatgt") -> opFn OpFGEq = (name "__floatgeq") -> opFn OpOr = (name "__or") -> opFn OpAnd = (name "__and") -> opFn ShL = (name "__shl") -> opFn ShR = (name "__shr") - -> opFn ToInt = (name "__toInt") -> opFn ToString = (name "__toString") -> opFn StringToFloat = (name "__stringToFloat") -> opFn FloatToString = (name "__floatToString") -> opFn CharToInt = (name "__charToInt") -> opFn IntToChar = (name "__intToChar") - -> opFn StringLength = (name "__strlen") -> opFn StringGetIndex = (name "__strgetIdx") -> opFn StringSubstr = (name "__substr") -> opFn StringHead = (name "__strHead") -> opFn StringTail = (name "__strTail") -> opFn StringRev = (name "__strRev") -> opFn StringFind = (name "__strFind") -> opFn StringSub = (name "__substr") -> opFn StringCons = (name "__strCons") - -> useropFn fn = UN $ "__op_" ++ concat (map opC fn) where -> opC c = "_" ++ show (fromEnum c) - -Pattern clauses - -> data RawClause = RawClause { lhs :: RawTerm, -> rhs :: RawTerm } -> | RawWithClause { lhs :: RawTerm, -> addproof :: Bool, -> scrutinee :: RawTerm, -> defn :: [RawClause] } -> deriving Show - -> mkApp :: String -> Int -> RawTerm -> [RawTerm] -> RawTerm -> mkApp file line f [] = f -> mkApp file line f (a:as) = mkApp file line (RApp file line f a) as - -For each raw definition, we'll translate it into something Ivor will understand -with all the placeholders added. For this we'll need to know how many -implicit arguments each function has. - -> data IvorFun = IvorFun { -> ivorFName :: Maybe Name, -> ivorFType :: (Maybe ViewTerm), -> implicitArgs :: Int, -> -- paramArgs :: Int, -> ivorDef :: Maybe IvorDef, -> rawDecl :: Decl, -- handy to keep around for display + extra data -> funFlags :: [CGFlag], -> lazyArgs :: [Int], -> staticArgs :: [Int] -> } -> | IvorProblem String -> deriving Show - -> getNameType :: IvorFun -> NameType -> getNameType i = case rawDecl i of -> Fun _ _ -> Free -> TermDef _ _ _ -> Free -> Prf _ _ -> Free -> Fwd _ _ _ -> Free -> Constructor -> DataCon -> _ -> Unknown - -> mkNameMap :: Ctxt IvorFun -> [(Name, Id)] -> mkNameMap ctxt = mapMaybe mknm (ctxtAlist ctxt) -> where mknm (n, IvorProblem _) = Nothing -> mknm (n, i) = do iname <- ivorFName i -> return (iname, n) - -Get all the pattern definitions. Get the user specified one, not the -Ivor expanded one (i.e. with the placeholders as the user specified) so -that we avoid pattern matching where the programmer didn't ask us to. - -> getRawPatternDefs :: Ctxt IvorFun -> Context -> -> [(Name, (ViewTerm, Patterns))] -> getRawPatternDefs raw ctxt = gdefs (ctxtAlist raw) where -> gdefs [] = [] -> gdefs ((n, IvorFun _ _ _ _ (decl@(LatexDefs _)) _ _ _):ds) = gdefs ds -> gdefs ((n, IvorFun _ _ _ _ (decl@(Fixity _ _ _)) _ _ _):ds) = gdefs ds -> gdefs ((n, IvorFun _ _ _ _ (decl@(Transform _ _)) _ _ _):ds) = gdefs ds -> gdefs ((n, IvorFun _ _ _ _ (decl@(SynDef _ _ _)) _ _ _):ds) = gdefs ds -> gdefs ((n, IvorFun _ _ _ _ (decl@(Freeze _ _ _ _)) _ _ _):ds) = gdefs ds -> gdefs ((n, ifun):ds) -> = let Just iname = ivorFName ifun in -> case (ivorFType ifun, ivorDef ifun) of -> (Just ty, Just (PattDef ps)) -> -> (iname, (ty,ps)):(gdefs ds) -> _ -> case getPatternDef ctxt iname of -> Right (ty,ps) -> (iname, (ty,ps)):(gdefs ds) -> _ -> gdefs ds - -Name definitions Ivor-side. - -> data IvorDef = PattDef !Patterns -- pattern matching function -> | ITyCon -- Type constructor -> | IDataCon -- Data constructor -> | SimpleDef !ViewTerm -- simple function definition -> | DataDef !Inductive Bool -- data type definition, generate elim -> | IProof [ITactic] Bool -- True if failable -> | Later -- forward declaration -> | LataDef -- forward declared data -> deriving Show - -A transformation is a function converting a ViewTerm to a new form. - -> data Transform = Trans String -> (Maybe (ViewTerm -> ViewTerm)) -> (Maybe TransData) - -A syntax definition is a syntax level transformation from one term to another -(macros, essentially). - -> data Syntax = Syntax Id [Id] RawTerm -> deriving Show - -Concrete transformation data, used for rebuilding constructor transforms - -> data TransData = Force (Maybe (Name, Name)) Int Name [Name] -> [(Name, ViewTerm)] Int -> | Collapse Name Name ViewTerm Int -> | Drop Name ViewTerm [Int] Int - -> data Opt = NoErasure | ShowRunTime | NoSpec | Verbose -> deriving (Show, Eq, Enum) - -> type Statics = [(Name, ([Int], Int, ViewTerm))] - -Things we've partially evaluated that transform rules already exist for -(so don't make another one) - -> type StaticUsed = [(Name, [ViewTerm])] - -> data IdrisState = IState { -> idris_context :: Ctxt IvorFun, -- function definitions -> idris_decls :: [Decl], -- all checked declarations -> idris_metavars :: [(Name, ViewTerm)], -- things still to prove -> idris_options :: [Opt], -- global options -> idris_fixities :: UserOps, -- infix operators and precedences -> idris_transforms :: [Transform], -- optimisations -> idris_syntax :: Ctxt Syntax, -- syntax macros -> idris_imports :: [FilePath], -- included files -> idris_names :: [(Name, Id)], -- map ivor names back to idris names -> idris_static :: Statics, -- map from functions to static args -> idris_static_used :: StaticUsed -> } - -> instance Show (Ctxt Syntax) where -> show xs = show (ctxtAlist xs) - -> initState :: [Opt] -> IdrisState -> initState opts = IState newCtxt [] [] opts (UO [] [] [] newCtxt) [] newCtxt [] [] [] [] - -Add implicit arguments to a raw term representing a type for each undefined -name in the scope, returning the number of implicit arguments the resulting -type has. - -We only want names which appear *in argument position*, e.g. P a we'd add a -but not P. [[We also don't want names which appear in the return type, since -they'll never be inferrable at the call site. (Not done this. Not convinced.) ]] - -> addImpl :: Ctxt IvorFun -> RawTerm -> (RawTerm, Int) -> addImpl = addImpl' True [] [] [] - -> addImplWith :: Implicit -> Ctxt IvorFun -> RawTerm -> (RawTerm, Int) -> addImplWith (Imp using params paramnames ns) = addImpl' True using params ns - -Bool says whether to pi bind unknown names -Also take a mapping of names to types ('using') --- if any name we need to -bind is in the list, use the given type. Also sort the resulting bindings -so that they are in the same order as in 'using', and appear after any -other introduced bindings. - -'params' is the arguments that the current group of definitions is parameterised over. -These should be added as *explicit* arguments. - -Need to do it twice, in case the first pass added names in the indices -(from using) - -> addImpl' :: Bool -> [(Id, RawTerm)] -> [(Id, RawTerm)] -> [Id] -> Ctxt IvorFun -> -> RawTerm -> (RawTerm, Int) -> addImpl' pi using params namespace ctxt raw' -> = let raw = parambind params raw' -> (newargs, totimp) = execState (addImplB [] raw True) ([],0) in -> if pi then -> let added = pibind Im (mknew newargs) raw in -> if null using -> then (added, totimp) -> else let (added', totimp') = addImpl' True [] [] namespace ctxt added in -> (added', totimp') -> else (raw, totimp) -> where addImplB :: [Id] -> RawTerm -> Bool -> State ([Id], Int) () -> addImplB env (RVar f l i _) argpos -> | i `elem` env = return () -> | Right _ <- ctxtLookup ctxt namespace i = return () - -Only do it in argument position - -> | argpos = do (nms, tot) <- get -> if (i `elem` nms) then return () -> else put (i:nms, tot+1) -> | otherwise = return () -> addImplB env ap@(RApp _ _ f a) argpos -> = do addImplB env f False -> addImplB env a True -> addImplB env (RAppImp _ _ _ f a) argpos -> = do addImplB env f False -> addImplB env a True -> addImplB env (RBind n (Pi Im _ ty) sc) argpos -> = do (nms, tot) <- get -> put (nms, tot+1) -> addImplB env ty argpos -> addImplB (n:env) sc argpos -> addImplB env (RBind n (Pi Ex _ ty) sc) argpos -> = do addImplB env ty True -> addImplB (n:env) sc argpos -> addImplB env (RBind n (Lam ty) sc) argpos -> = do addImplB env ty argpos -> addImplB (n:env) sc argpos -> addImplB env (RBind n (RLet val ty) sc) argpos -> = do addImplB env val argpos -> addImplB env ty argpos -> addImplB (n:env) sc argpos -> addImplB env (RInfix _ _ op l r) argpos -> = do addImplB env l argpos -> addImplB env r argpos -> addImplB env (RUserInfix _ _ _ op l r) argpos -> = do addImplB env l argpos -> addImplB env r argpos -> addImplB env _ _ = return () - -> mknew :: [Id] -> [(Id, RawTerm)] -> mknew args = map fst (sortBy ordIdx (map addTy args)) - -> ordIdx (a, x) (b, y) = compare x y - -> addTy n = case lookupIdx n using of -> Just (t, i) -> ((n,t), i) -> _ -> ((n,RPlaceholder), -1) - -> parambind :: [(Id, RawTerm)] -> RawTerm -> RawTerm -> parambind xs (RBind n b@(Pi Im strict ty) sc) = RBind n b (parambind xs sc) -> parambind xs sc = pibind Ex xs sc - -> pibind :: Plicit -> [(Id, RawTerm)] -> RawTerm -> RawTerm -> pibind plicit [] raw = raw -> pibind plicit ((n, ty):ns) raw -> = RBind n (Pi plicit [] ty) (pibind plicit ns raw) - -Is this, or something like it, in the Haskell libraries? - -> lookupIdx :: Eq a => a -> [(a,b)] -> Maybe (b, Int) -> lookupIdx x xs = li' 0 x xs -> where li' i x [] = Nothing -> li' i x ((y,v):ys) | x == y = Just (v, i) -> | otherwise = li' (i+1) x ys - -Convert a raw term with all the implicit things added into an ivor term -ready for typechecking - -> toIvorName :: Id -> Name -> toIvorName i = name (show i) - -Lookup the original Idris name of a name from Ivor. Makes up a name if -the name doesn't exist. - -> fromIvorName :: IdrisState -> Name -> Id -> fromIvorName ist i = case lookup i (idris_names ist) of -> Just n -> n -> _ -> UN (show i) - -Make up a plausible Idris name from a name from Ivor (only really useful -for display purposes, or if it really doesn't matter whether the name exists -or not) - -> fromIvorName_ :: Name -> Id -> fromIvorName_ i = UN (show i) - -For desugaring -- do blocks, idiom brackets and syntax definitions - -> data UndoInfo = UI Id Int -- bind, bind implicit -> Id Int -- return, return implicit -> Id Int -- pure, pure implicit -> Id Int -- ap, ap implicit - -> data ModInfo = MI Id -- namespace -> [(Id, RawTerm)] -- parameters - -Implicit argument information; current using clause and parameters. We also need to know -the functions in the current block, and which arguments to add automatically, because the -programmer doesn't have to write them down inside the param block. - -> data Implicit = Imp { impUsing :: [(Id, RawTerm)], -- 'using' -> params :: [(Id, RawTerm)], -- extra params -> paramNames :: [(Id, [Id])], -- functions and params in the current block -> thisNamespace :: [Id] -> } - -> noImplicit = Imp [] [] [] [] - -> addUsing :: Implicit -> Implicit -> Implicit -> addUsing (Imp a b pns ns) (Imp a' b' pns' ns') -- ns always == ns' -> = Imp (a++a') (b++b') (pns++pns') ns - -> addParams :: Implicit -> [(Id, RawTerm)] -> Implicit -> addParams (Imp a b pns ns) newps = Imp a (b++newps) pns ns - -> addNS :: Implicit -> Id -> Implicit -> addNS (Imp a b pns ns) n = Imp a b pns (n:ns) - -> fullName :: Implicit -> Id -> Id -> fullName imp n = mkName (thisNamespace imp) n - -> addParamName :: Implicit -> Id -> Implicit -> addParamName imp@(Imp u ps pns ns) n -> = case lookup n pns of -> Just _ -> imp -> Nothing -> Imp u ps ((n, (map fst ps)):pns) ns - -> bindName = ioname "bind" -> ibindName = ioname "ibind" -> retName = ioname "ret" -> ioretName = ioname "IOReturn" -> iodoName = ioname "IODo" -> ioliftName = ioname "IOLift" -> applyName = ioname "apply" - -> bindNamei = toIvorName bindName -> ibindNamei = toIvorName ibindName -> retNamei = toIvorName retName -> ioretNamei = toIvorName ioretName -> iodoNamei = toIvorName iodoName -> ioliftNamei = toIvorName ioliftName -> applyNamei = toIvorName applyName - -> ioname n = NS [UN "IO"] (UN n) -> ionamei n = toIvorName (ioname n) - -> defDo = UI bindName 2 retName 1 retName 1 applyName 2 - -Give names to unnamed metavariables, and record any associated proof -scripts - -> insertMetas :: Id -> RawTerm -> State (Int, [(Id, [ITactic], Bool)]) RawTerm -> insertMetas fname tm = im tm -> where im (RMetavarPrf (UN "") tacs prf) -> = do (h, ts) <- get -> let nm = mkName fname h -> put (h+1, (nm, tacs, prf):ts) -> return $ RMetavar nm -> im (RApp f l x a) -> = do x' <- im x -> a' <- im a -> return $ RApp f l x' a' -> im (RAppImp f l arg x a) -> = do x' <- im x -> a' <- im a -> return $ RAppImp f l arg x' a' -> im (RBind n bind t) -> = do bind' <- imb bind -> t' <- im t -> return $ RBind n bind' t -> im (RInfix f l op x y) -> = do x' <- im x -> y' <- im y -> return $ RInfix f l op x' y' -> im (RUserInfix f l b op x y) -> = do x' <- im x -> y' <- im y -> return $ RUserInfix f l b op x' y' -> im (RDo ds) = do ds' <- mapM imd ds -> return $ RDo ds' -> im (RIdiom t) = do t' <- im t -> return $ RIdiom t' -> im (RPure t) = do t' <- im t -> return $ RPure t' -> im x = return x - -> imb (Pi p opts t) = do t' <- im t -> return $ Pi p opts t' -> imb (Lam t) = do t' <- im t -> return $ Lam t -> imb (RLet t v) = do t' <- im t -> v' <- im v -> return $ RLet t' v' - -> imd (DoBinding f l i x y) -> = do x' <- im x -> y' <- im y -> return $ DoBinding f l i x' y' -> imd (DoLet f l i x y) -> = do x' <- im x -> y' <- im y -> return $ DoLet f l i x' y' -> imd (DoExp f l x) -> = do x' <- im x -> return $ DoExp f l x' - -> mkName (UN n) i = UN ("__"++n++"_"++show i) -> mkName (MN n j) i = MN ("__"++n++"_"++show i) j - - -> insertMetasClauses :: Id -> [(Id, RawClause)] -> -> State (Int, [(Id, [ITactic], Bool)]) [(Id, RawClause)] -> insertMetasClauses fn xs = mapM imcp xs where -> imcp (n, t) = do t' <- imc t -> return (n, t') -> imc (RawClause lhs rhs) = -> do lhs' <- insertMetas fn lhs -> rhs' <- insertMetas fn rhs -> return (RawClause lhs' rhs') -> imc (RawWithClause lhs prf scr def) = -> do lhs' <- insertMetas fn lhs -> scr' <- insertMetas fn scr -> def' <- mapM imc def -> return (RawWithClause lhs' prf scr' def') - -> toIvor :: UserOps -> UndoInfo -> Id -> RawTerm -> ViewTerm -> toIvor uo ui fname tm = evalState (toIvorS tm) (0,1) -> where -> toIvorS :: RawTerm -> State (Int, Int) ViewTerm -> toIvorS (RVar f l n ty) = return $ Annotation (FileLoc f l) (Name ty (toIvorName n)) -> toIvorS (RVars f l ns) = return $ Annotation (FileLoc f l) (Overloaded (map toIvorName ns)) -> toIvorS ap@(RApp file line f a) -> = do f' <- toIvorS f -> a' <- toIvorS a -> return (Annotation (FileLoc file line) (App f' a')) -> toIvorS (RBind (MN "X" 0) (Pi _ _ ty) sc) -> = do ty' <- toIvorS ty -> sc' <- toIvorS sc -> (i, x) <- get -> put (i+1, x) -> return $ Forall (toIvorName (MN "X" i)) ty' sc' -> toIvorS (RBind n (Pi _ _ ty) sc) -> = do ty' <- toIvorS ty -> sc' <- toIvorS sc -> return $ Forall (toIvorName n) ty' sc' -> toIvorS (RBind n (Lam ty) sc) -> = do ty' <- toIvorS ty -> sc' <- toIvorS sc -> return $ Lambda (toIvorName n) ty' sc' -> toIvorS (RBind n (RLet val ty) sc) -> = do ty' <- toIvorS ty -> val' <- toIvorS val -> sc' <- toIvorS sc -> return $ Let (toIvorName n) ty' val' sc' -> toIvorS (RConst _ _ c) = return $ toIvorConst c -> toIvorS RPlaceholder = return Placeholder -> toIvorS (RMetavar (UN "")) -- no name, so make on eup -> = do (i, h) <- get -> put (i, h+1) -> return $ Metavar (toIvorName (mkName fname h)) -> toIvorS (RMetavar n) = return $ Metavar (toIvorName n) -> toIvorS (RInfix file line JMEq l r) -> = do l' <- toIvorS l -> r' <- toIvorS r -> return $ Annotation (FileLoc file line) -> (apply (Name Unknown (opFn JMEq)) -> [Placeholder, Placeholder,l',r']) -> toIvorS (RInfix file line OpEq l r) -> = do l' <- toIvorS l -> r' <- toIvorS r -> return $ Annotation (FileLoc file line) -> (apply (Name Unknown (opFn OpEq)) -> [Placeholder,l',r']) -> toIvorS (RInfix file line op l r) -> = do l' <- toIvorS l -> r' <- toIvorS r -> return $ Annotation (FileLoc file line) -> (apply (Name Unknown (opFn op)) [l',r']) -> toIvorS (RDo dos) = do tm <- undo ui dos -> toIvorS tm -> toIvorS (RReturn f l) -> = do let (UI _ _ ret retImpl _ _ _ _) = ui -> toIvorS $ mkApp f l (RVar f l ret Unknown) (take retImpl (repeat RPlaceholder)) -> toIvorS (RIdiom tm) = do let tm' = unidiom ui tm -> toIvorS tm' -> toIvorS (RPure t) = toIvorS t -> toIvorS RRefl = return $ apply (Name Unknown (name "refl")) [Placeholder] -> toIvorS (RError f l x) = error (f ++ ":" ++ show l ++ ":" ++ x) -> toIvorS x = error ("Can't happen, toIvorS: " ++ show x) - -> mkName (UN n) i = UN (n++"_"++show i) -> mkName (MN n j) i = MN (n++"_"++show i) j - -> toIvorConst (Num x) = Constant x -> toIvorConst (Str str) = Constant str -> toIvorConst (Bo True) = Name Unknown (name "true") -> toIvorConst (Bo False) = Name Unknown (name "false") -> toIvorConst (Ch c) = Constant c -> toIvorConst (Fl f) = Constant f -> toIvorConst TYPE = Star -> toIvorConst LTYPE = LinStar -> toIvorConst StringType = Name Unknown (name "String") -> toIvorConst IntType = Name Unknown (name "Int") -> toIvorConst FloatType = Name Unknown (name "Float") -> toIvorConst CharType = Name Unknown (name "Char") -> toIvorConst PtrType = Name Unknown (name "Ptr") -> toIvorConst (Builtin ty) = Name Unknown (name ty) - -Convert a raw term to an ivor term, adding placeholders - -> makeIvorTerm :: Implicit -> UndoInfo -> UserOps -> Id -> Ctxt IvorFun -> RawTerm -> ViewTerm -> makeIvorTerm using ui uo n ctxt tm -> = let expraw = addPlaceholders ctxt using uo tm in -> toIvor uo ui n expraw - -Apply syntax macros, and fixity declarations. -Assume they are terminating (perhaps check this by not -allowing recursion in them). - -> syntax :: Ctxt IvorFun -> Implicit -> UserOps -> RawTerm -> RawTerm -> syntax ctxt using (UO uo _ _ syns) tm -> = let ans = shiftimpl (syn (fixes tm)) in -> -- trace ("BEFORE: " ++ showImp False (fixes tm) ++ "\nAFTER: " ++ -> -- showImp False ans) -> ans -> where syn (RVar f l n _) = doSynN f l n syns -> syn app@(RApp file line f a) -> = doSyn (RApp file line (syn f) (syn a)) -> syns (syn f) [syn a] -> syn (RAppImp file line n f a) = RAppImp file line n (syn f) (syn a) -> syn (RBind n (Pi p opts t) sc) -> = RBind n (Pi p opts (syn t)) (syn sc) -> syn (RBind n (Lam t) sc) -> = RBind n (Lam (syn t)) (syn sc) -> syn (RBind n (RLet v t) sc) -> = RBind n (RLet (syn v) (syn t)) (syn sc) -> syn (RInfix f l op x y) -> = RInfix f l op (syn x) (syn y) -> syn (RUserInfix file line b op l r) -> = RUserInfix file line b op (syn l) (syn r) -> -- = RUserInfix f l b op (syn x) (syn y) -> syn (RDo ds) = RDo $ map synd ds -> syn (RIdiom t) = RIdiom (syn t) -> syn (RPure t) = RPure (syn t) -> syn t = t - -> synd (DoBinding f l n x y) -> = DoBinding f l n (syn x) (syn y) -> synd (DoLet f l n x y) -> = DoLet f l n (syn x) (syn y) -> synd (DoExp f l x) -> = DoExp f l (syn x) - -> doSyn o syns (RApp _ _ f a) args = doSyn o syns f (a:args) -> doSyn o syns v args -> = case v of -> RVar f l n _ -> -> case findSyn n syns of -> Just (a, rhs) -> -- trace (show (n, rhs, a, args)) $ -> if (length a == length args) -> then syn $ replSyn f l rhs (zip a args) -> else o -> Nothing -> o -> _ -> o - -> doSynN f l n syns = case findSyn n syns of -> Just ([], rhs) -> syn $ replSyn f l rhs [] -> _ -> RVar f l n Unknown - -> findSyn n synct = -> case ctxtLookup synct (thisNamespace using) n of -> (Right (Syntax f as rhs)) -> Just (as, rhs) -> (Left err) -> Nothing -- FIXME: need to report an error -> -- if it's ambiguous - -> -- findSyn n [] = Nothing -> -- findSyn n ((Syntax f as rhs):xs) | n == f = Just (as, rhs) -> -- | otherwise = findSyn n xs - -> replSyn f l t@(RVar _ _ n ty) as = case lookup n as of -> Just v -> v -> Nothing -> RVar f l n ty -> replSyn f l (RApp _ _ fn a) as -> = RApp f l (replSyn f l fn as) (replSyn f l a as) -> replSyn f l (RInfix _ _ op x y) as -> = RInfix f l op (replSyn f l x as) (replSyn f l y as) -> replSyn f l (RUserInfix _ _ b op x y) as -> = RUserInfix f l b op (replSyn f l x as) (replSyn f l y as) -> replSyn f l (RAppImp _ _ x fn a) as -> = RAppImp f l x (replSyn f l fn as) (replSyn f l a as) -> replSyn f l (RBind n b t) as -> = RBind n (replBind f l b as) -> (replSyn f l t (filter (\ (x,_) -> x /= n) as)) -> replSyn _ _ x _ = x - -> replBind f l (Pi p os t) as = Pi p os (replSyn f l t as) -> replBind f l (Lam t) as = Lam (replSyn f l t as) -> replBind f l (RLet v t) as = RLet (replSyn f l v as) (replSyn f l t as) - -> fixes fix@(RUserInfix _ _ _ _ _ _) = -> case fixFix uo fix of -> (RUserInfix file line _ op l r) -> -> fixes (RApp file line -> (RApp file line -> (RVar file line (useropFn op) Free) l) r) -> (RError f l x) -> RError f l x -> fixes (RApp file line f a) = RApp file line (fixes f) (fixes a) -> fixes (RAppImp file line n f a) -> = RAppImp file line n (fixes f) (fixes a) -> fixes (RBind n (Lam t) sc) = RBind n (Lam (fixes t)) (fixes sc) -> fixes (RBind n (Pi p opts t) sc) -> = RBind n (Pi p opts (fixes t)) (fixes sc) -> fixes (RBind n (RLet v t) sc) -> = RBind n (RLet (fixes v) (fixes t)) (fixes sc) -> fixes (RInfix file line op l r) -> = RInfix file line op (fixes l) (fixes r) -> fixes (RIdiom t) = RIdiom (fixes t) -> fixes (RPure t) = RPure (fixes t) -> fixes (RDo d) = RDo (map fixesd d) -> fixes t = t - -> fixesd (DoBinding f l n x y) = DoBinding f l n (fixes x) (fixes y) -> fixesd (DoLet f l n x y) = DoLet f l n (fixes x) (fixes y) -> fixesd (DoExp f l x) = DoExp f l (fixes x) - -> shiftimpl x = let (imps, t) = simp [] x in -> pibind Im (reverse imps) t -> simp imps (RBind n (Pi Im _ t) sc) -> = simp ((n,t):imps) sc -> simp imps (RBind n (Pi p o t) sc) -> = let (imps', sc') = simp imps sc in -> (imps', RBind n (Pi p o t) sc') -> simp imps x = (imps, x) - -> syntaxClause :: Ctxt IvorFun -> Implicit -> UserOps -> RawClause -> -> RawClause -> syntaxClause ctxt imp uo (RawClause l r) -> = (RawClause (syntax ctxt imp uo l) -> (syntax ctxt imp uo r)) -> syntaxClause ctxt imp uo (RawWithClause lhs prf scr def) -> = (RawWithClause (syntax ctxt imp uo lhs) prf -> (syntax ctxt imp uo scr) -> (map (syntaxClause ctxt imp uo) def)) - -Add placeholders so that implicit arguments can be filled in. Also desugar user infix apps. -FIXME: I think this'll fail if names are shadowed. - -> addPlaceholders :: Ctxt IvorFun -> Implicit -> UserOps -> RawTerm -> RawTerm -> addPlaceholders ctxt using uops@(UO uo _ _ syns) tm -> = ap [] (syntax ctxt using uops tm) -> -- Count the number of args we've made explicit in an application -> -- and don't add placeholders for them. Reset the counter if we get -> -- out of an application -> where ap ex v@(RVar f l n _) -> = case ctxtLookupName ctxt (thisNamespace using) n of -> -- leave syntax definitions alone and expand later -> Right (IvorFun _ _ _ _ (SynDef _ _ _) _ _ _, _) -> -> RVar f l n Unknown -> Right (ifn@(IvorFun _ (Just ty) imp _ _ _ _ _), fulln) -> -> let pargs = case lookup n pnames of -> Nothing -> [] -> Just ids -> map (\i -> RVar f l i Bound) ids in -> mkApp f l (RVar f l fulln (getNameType ifn)) -> ((mkImplicitArgs -> (map fst (fst (getBinders ty []))) imp ex) ++ pargs) -> Left err@(Ambiguous _ ns) -> RError f l (show err) -- RVars f l ns -> Left err@(WrongNamespace _ _) -> RError f l (show err) -> Right (ifn, fulln) -> RVar f l fulln (getNameType ifn) -> _ -> RVar f l n Unknown -> ap ex (RExpVar f l n) -> = case ctxtLookupName ctxt (thisNamespace using) n of -> Right (ifn@(IvorFun _ (Just ty) imp _ _ _ _ _), fulln) -> RVar f l fulln (getNameType ifn) -> Left err@(Ambiguous _ _) -> RError f l (show err) -> Left err@(WrongNamespace _ _) -> RError f l (show err) -> Right (ifn, fulln) -> RVar f l fulln (getNameType ifn) -> _ -> RVar f l n Unknown -> ap ex (RAppImp file line n f a) = (ap ((toIvorName n,(ap [] a)):ex) f) -> ap ex app@(RApp file line f a) = -> RApp file line (ap ex f) (ap [] a) -> ap ex (RBind n (Pi p l ty) sc) -> = RBind n (Pi p l (ap [] ty)) (ap [] sc) -> ap ex (RBind n (Lam ty) sc) -> = RBind n (Lam (ap [] ty)) (ap [] sc) -> ap ex (RBind n (RLet val ty) sc) -> = RBind n (RLet (ap [] val) (ap [] ty)) (ap [] sc) -> ap ex (RInfix file line op l r) = RInfix file line op (ap [] l) (ap [] r) -> ap ex fix@(RUserInfix file line _ op l r) -> = -- case fixFix uo fix of -> -- (RUserInfix file line _ op l r) -> -> ap ex (RApp file line -> (RApp file line (RVar file line (useropFn op) Free) l) r) -> -- (RError f l x) -> RError f l x -> ap ex (RDo ds) = RDo (map apdo ds) -> ap ex (RIdiom tm) = RIdiom (ap [] tm) -> ap ex (RPure tm) = RPure (ap [] tm) -> ap ex r = r - -> apdo (DoExp f l r) = DoExp f l (ap [] r) -> apdo (DoBinding file line x t r) = DoBinding file line x (ap [] t) (ap [] r) -> apdo (DoLet file line x t r) = DoLet file line x (ap [] t) (ap [] r) - -> pnames = paramNames using - -Go through the arguments; if an implicit argument has the same name as one -in our list of explicit names to add, add it. - -> mkImplicitArgs :: [Name] -> Int -> [(Name, RawTerm)] -> [RawTerm] -> mkImplicitArgs _ 0 _ = [] -- No more implicit -> mkImplicitArgs [] i ns = [] -- No more args -> mkImplicitArgs (n:ns) i imps -> = case lookup n imps of -> Nothing -> RPlaceholder:(mkImplicitArgs ns (i-1) imps) -> Just v -> v:(mkImplicitArgs ns (i-1) imps) - -> getBinders (Forall n ty sc) acc = (getBinders sc ((n,ty):acc)) -> getBinders (Annotation _ t) acc = getBinders t acc -> getBinders sc acc = (reverse acc, sc) - - -> undo :: UndoInfo -> [Do] -> State (Int, Int) RawTerm -> undo ui [] = fail "The last statement in a 'do' block must be an expression" -> undo ui [DoExp f l last] = return last -> undo ui@(UI bind bindimpl _ _ _ _ _ _) ((DoBinding file line v' ty exp):ds) -> = -- bind exp (\v' . [[ds]]) -> do ds' <- undo ui ds -> let k = RBind v' (Lam ty) ds' -> return $ mkApp file line (RVar file line bind Unknown) -> ((take bindimpl (repeat RPlaceholder)) ++ [exp, k]) -> undo ui ((DoLet file line v' ty exp):ds) -> = do ds' <- undo ui ds -> return $ RBind v' (RLet exp ty) ds' -> undo ui@(UI bind bindimpl _ _ _ _ _ _) ((DoExp file line exp):ds) -> = -- bind exp (\_ . [[ds]]) -> do ds' <- undo ui ds -> (i, h) <- get -> put (i+1, h) -> let k = RBind (MN "x" i) (Lam RPlaceholder) ds' -> return $ mkApp file line (RVar file line bind Unknown) -> ((take bindimpl (repeat RPlaceholder)) ++ [exp, k]) - --- > unret :: UndoInfo -> RawTerm -> RawTerm --- > unret (UI _ _ ret retImpl _ _ _ _) (RApp f l (RVar _ _ (UN "return")) arg) --- > = mkApp f l (RVar f l ret) ((take retImpl (repeat RPlaceholder)) ++ [arg]) --- > unret ui (RApp f l x a) = RApp f l (unret ui x) (unret ui a) --- > unret ui (RAppImp f l n x a) = RAppImp f l n (unret ui x) (unret ui a) --- > unret ui (RInfix f l op x y) = RInfix f l op (unret ui x) (unret ui y) --- > unret ui (RBind n (Pi pl z tm) sc) = RBind n (Pi pl z (unret ui tm)) (unret ui sc) --- > unret ui (RBind n (Lam tm) sc) = RBind n (Lam (unret ui tm)) (unret ui sc) --- > unret ui (RBind n (RLet tm ty) sc) = RBind n (RLet (unret ui tm) (unret ui ty)) (unret ui sc) --- > unret ui (RUserInfix f l b n x y) = RUserInfix f l b n (unret ui x) (unret ui y) --- > unret ui (RIdiom tm) = RIdiom (unret ui tm) --- > unret ui (RPure tm) = RPure (unret ui tm) --- > unret ui x = x - -TODO: Get names out of UndoInfo - -> unidiom :: UndoInfo -> RawTerm -> RawTerm -> unidiom ui@(UI _ _ _ _ pure pureImpl _ _) (RApp file line f (RPure x)) -> = mkApp file line (RVar file line pure Unknown) -> ((take pureImpl (repeat RPlaceholder)) ++ [mkApp file line f [x]]) -> unidiom ui@(UI _ _ _ _ pure pureImpl _ _) (RApp file line f RPlaceholder) -> = mkApp file line (RVar file line pure Unknown) -> ((take pureImpl (repeat RPlaceholder)) ++ [mkApp file line f [RPlaceholder]]) -> unidiom ui@(UI _ _ _ _ _ _ ap apImpl) (RApp file line f x) -> = mkApp file line (RVar file line ap Unknown) -> ((take apImpl (repeat RPlaceholder)) ++ -> [unidiom ui f, x]) -> unidiom ui@(UI _ _ _ _ pure pureImpl _ _) x -> = let (file, line) = getFileLine x in -> mkApp file line (RVar file line pure Unknown) -> ((take pureImpl (repeat RPlaceholder)) ++ [x]) - -> testCtxt = addEntry newCtxt [] (UN "Vect") undefined - -> dump :: Ctxt IvorFun -> String -> dump ctxt = concat $ map dumpFn (ctxtAlist ctxt) -> where dumpFn (_,IvorFun n ty imp def _ _ _ _) = -> show n ++ " : " ++ show ty ++ "\n" ++ -> " " ++ show imp ++ " implicit\n" ++ -> show def ++ "\n\n" - -> mkRName n = UN (show n) - -> getOp v allops -> = let ops = mapMaybe (\x -> if opFn x == v -> then Just x -> else Nothing) allops -> in if null ops then Nothing -> else Just (head ops) - -Convert an ivor term back to a raw term, for pretty printing purposes. -Use the context to decide which arguments to make implicit - -FIXME: If a name is bound locally, don't add implicit args. - -> unIvor :: Ctxt IvorFun -> ViewTerm -> RawTerm -> unIvor ctxt tm = unI tm [] where - -Built-in constants firsts - -> unI (Name _ v) [] -> | v == name "Int" = RConst "[val]" 0 IntType -> | v == name "String" = RConst "[val]" 0 StringType -> unI (Name _ v) [x,y] -> | v == name "refl" = RApp "[val]" 0 RRefl y - -Now built-in operators - -> unI (Name _ v) [_,_,x,y] -> | v == opFn JMEq = RInfix "[val]" 0 JMEq x y -> unI (Name _ v) [_,x,y] -> | v == opFn OpEq = RInfix "[val]" 0 OpEq x y -> unI (Name _ v) [x,y] -> | Just op <- getOp v allOps = RInfix "[val]" 0 op x y -> unI (Name _ v) args -> = case ctxtLookup ctxt [] (mkRName v) of -> Right fdata -> mkImpApp "[val]" 0 (implicitArgs fdata) -> (argNames (ivorFType fdata)) (RVar "[val]" 0 (mkRName v) Unknown) args -> _ -> unwind (RVar "[val]" 0 (mkRName v) Unknown) args -> unI (App f a) args = unI f ((unI a []):args) -> unI (Lambda v ty sc) args = unwind (RBind (mkRName v) (Lam (unI ty [])) (unI sc [])) args -> unI (Forall v ty sc) args = unwind (RBind (mkRName v) (Pi Ex [] (unI ty [])) (unI sc [])) args -> unI (Let v ty val sc) args = unwind (RBind (mkRName v) -> (RLet (unI val []) (unI ty [])) -> (unI sc [])) args -> unI Star [] = RConst "[val]" 0 TYPE -> unI LinStar [] = RConst "[val]" 0 LTYPE -> unI (Constant c) [] = let try f = fmap (RConst "[val]" 0 . f) $ cast c -> in fromJust $ msum [try Num, try Str, try Ch, try Fl] -> unI (Annotation _ x) args = unI x args -> unI (Metavar n) args = RMetavar (mkRName n) -> unI Placeholder args = RPlaceholder -> unI x args = error (show x) - -> unwind = mkImpApp "[val]" 0 0 [] - -> argNames :: Maybe ViewTerm -> [Id] -> argNames Nothing = [] -> argNames (Just ty) = an ty where -> an (Forall n ty sc) = (mkRName n):(an sc) -> an (Annotation _ t) = an t -> an x = [] - -> mkImpApp :: String -> Int -> Int -> [Id] -> RawTerm -> [RawTerm] -> RawTerm -> mkImpApp file line i (n:ns) tm (a:as) -> | i>0 = mkImpApp file line (i-1) ns (RAppImp file line n tm a) as -> | otherwise = mkImpApp file line 0 ns (RApp file line tm a) as -> mkImpApp file line _ _ tm (a:as) = mkImpApp file line 0 [] (RApp file line tm a) as -> mkImpApp _ _ _ _ tm _ = tm - - -Show a raw term; either show or hide implicit arguments according to -boolean flag (true for showing them) - -> showImp :: Bool -> RawTerm -> String -> showImp imp tm = showP 10 tm where -> showP p (RVar _ _ (UN "__Unit") _) = "()" -> showP p (RVar _ _ (UN "__Empty") _) = "_|_" -> showP p (RVar _ _ i _) = case (getOpName i) of -> (True, o) -> "(" ++ o ++ ")" -> (False, o) -> o -> showP p RRefl = "refl" -> showP p (RApp _ _ f a) = bracket p 1 $ showP 1 f ++ " " ++ showP 0 a -> showP p (RAppImp _ _ n f a) -> | imp = bracket p 1 $ showP 1 f ++ " {"++show n ++ " = " ++ showP 0 a ++ "} " -> | otherwise = showP 1 f -> showP p (RBind n (Lam ty) sc) -> = bracket p 2 $ -> "\\ " ++ show n ++ " : " ++ showP 10 ty ++ " => " ++ showP 10 sc -> showP p (RBind n (Pi im _ ty) sc) -> | internal n && not imp -- hack for spotting unused names quickly! -> = bracket p 2 $ showP 1 ty ++ " -> " ++ showP 10 sc -> | otherwise -> = bracket p 2 $ -> ob im ++ show n ++ " : " ++ showP 10 ty ++ cb im ++ " -> " ++ -> showP 10 sc -> where ob Im = "{" -> ob Ex = "(" -> cb Im = "}" -> cb Ex = ")" -> internal (UN ('_':'_':_)) = True -> internal (MN _ _) = True -> internal _ = False -> showP p (RBind n (RLet val ty) sc) -> = bracket p 2 $ -> "let " ++ show n ++ " : " ++ showP 10 ty ++ " = " ++ showP 10 val -> ++ " in " ++ showP 10 sc -> showP p (RConst _ _ c) = show c -> showP p (RInfix _ _ op l r) = bracket p 5 $ -> showP 4 l ++ show op ++ showP 4 r -> showP _ x = show x -> bracket outer inner str | inner>outer = "("++str++")" -> | otherwise = str - -> showVT :: Ctxt IvorFun -> ViewTerm -> String -> showVT ivs t = showImp False (unIvor ivs t) - -If we haven't got a line number for an error message, pick where the definition -starts as a best guess. - -> guessContext :: IvorFun -> TTError -> TTError -> guessContext _ e@(ErrContext _ _) = e -> guessContext ifn e = case (ivorFType ifn) of -> Just (Annotation (FileLoc f l) _) -> -> ErrContext (f ++ ":" ++ show l ++ ":") e -> _ -> e -- ErrContext (show (ivorFType ifn)) e - -> idrisError :: Ctxt IvorFun -> TTError -> String -> idrisError ivs (CantUnify x y) = "Can't unify " ++ (showVT ivs x) ++ " and " ++ -> (showVT ivs y) -> idrisError ivs (Message str) = str -> idrisError ivs (Unbound clause clty rhs rhsty names) -> = "Unbound names in " ++ showVT ivs rhs ++ -> " : " ++ showVT ivs clty ++ -> " " ++ show names -> idrisError ivs (NoSuchVar n) = "No such variable as " ++ show n -> idrisError ivs (CantInfer n tm) = "Can't infer value for " ++ show n ++ " in " ++ (showVT ivs tm) -> idrisError ivs (ErrContext s e) = s ++ idrisError ivs e -> idrisError ivs (AmbiguousName ns) = "Ambiguous name " ++ show ns -> idrisError ivs (NotConvertible x y) = "Not convertible: " ++ (showVT ivs x) ++ " and " ++ (showVT ivs y) - - -> getOpName (UN ('_':'_':'o':'p':'_':op)) = (True, showOp op) where -> showOp ('_':cs) = case span isDigit cs of -> (op, rest) -> toEnum (read op) : showOp rest -> showOp _ = "" -> getOpName s = (False, show s) - -Correct the precedences in a user defined infix operator term using Dijkstra's -Shunting Yard algorithm. - -> fixFix :: Fixities -> RawTerm -> RawTerm -> fixFix ops top@(RUserInfix f l b op x y) -> = let toks = tok top -> shunted = shunt ops [] toks in -> rebuild [] shunted -> fixFix ops x = x - -> data OpTok = Op String Int String -> | OTm RawTerm -> | OpenB -> | CloseB -> deriving Show - -> tok (RUserInfix f l False op x y) -> = tok x ++ ((Op f l op):tok y) -> tok (RUserInfix f l True op x y) -> = OpenB:(tok x ++ (Op f l op):tok y) ++ [CloseB] -> tok x = [OTm x] - -> shunt :: Fixities -> [OpTok] -> [OpTok] -> [OpTok] -> shunt ops stk (OTm x:toks) = OTm x:(shunt ops stk toks) -> shunt ops stk (op@(Op f l _):toks) -> = let (stk', out) = prec [] stk op in -> out ++ shunt ops stk' toks -> where prec out (op2@(Op f2 l2 o2):opstk) op1@(Op f1 l1 o1) -> = case (lookup o1 ops, lookup o2 ops) of -> (Just (LeftAssoc, prec1), Just (assoc2, prec2)) -> -> if (prec1<=prec2) then -> prec (op2:out) opstk op1 -> else -> (op1:op2:opstk, reverse out) -> (Just (RightAssoc, prec1), Just (assoc2, prec2)) -> -> if (prec1 prec (op2:out) opstk op1 -> else -> (op1:op2:opstk, reverse out) -> (Nothing, Nothing) -> (opstk, OTm (RError f1 l1 (":unknown operators " ++ show o1 ++ " and " ++ show o2)):out) -> (Nothing, _) -> (opstk, OTm (RError f1 l1 (":unknown operator " ++ show o1)):out) -> (_, Nothing) -> (opstk, OTm (RError f2 l2 (":unknown operator " ++ show o2)):out) -> prec out opstk op1 = (op1:opstk, reverse out) - -> shunt ops stk (OpenB:toks) = shunt ops (OpenB:stk) toks -> shunt ops stk (CloseB:toks) = let (stk',out) = popToLeft [] stk in -> out ++ shunt ops stk' toks -> where popToLeft out (OpenB:stk) = (stk, reverse out) -> popToLeft out (x:stk) = popToLeft (x:out) stk -> popToLeft out [] = error "Can't happen, no left paren" -> shunt ops (x:stk) [] = x:(shunt ops stk []) -> shunt ops [] [] = [] - -> rebuild :: [RawTerm] -> [OpTok] -> RawTerm -> rebuild stk (OTm x:xs) = rebuild (x:stk) xs -> rebuild (x:y:stk) (Op f l op:xs) -> = rebuild ((RUserInfix f l True op y x):stk) xs -> rebuild (x:[]) [] = x -> rebuild stk xs = error $ "Can't happen: rebuild " ++ show (stk, xs) - -Old version: - - -Only need to worry if the left term is not bracketed. Otherwise leave it alone. -Also need to sort out inner ops first. - - fixFix ops top@(RUserInfix f l b op x y) - = let fixed = fixFix' ops top in -- (RUserInfix f l b op x y) - if (fixed==top) then fixed else fixFix ops fixed - fixFix ops x = x - - - - - -> fixFix' ops top@(RUserInfix file line _ opr -> (RUserInfix _ _ False opl a b) c) = -> case (lookup opl ops, lookup opr ops) of -> (Just (assocl, precl), Just (assocr, precr)) -> -> doFix assocl precl assocr precr a opl b opr c -> (Nothing, Nothing) -> RError file line $ ":unknown operators " ++ show opl ++ " and " ++ show opr -> (Nothing, _) -> RError file line (":unknown operator " ++ show opl) -> (_, Nothing) -> RError file line (":unknown operator " ++ show opr) -> where -> doFix al pl ar pr a opl b opr c -> | pr > pl = mkOp False opl (fixFix' ops a) (fixFix' ops (mkOp False opr b c)) -> | pr < pl = mkOp False opr (fixFix' ops (mkOp False opl a b)) (fixFix' ops c) - -In the following cases, change the top level operator, put explicit brackets in, then -rewrite the whole thing again. Termination guaranteed since the size of the expression -we check (i.e. the non-bracketed part) is smaller. - -> | pr == pl && al == LeftAssoc && ar == LeftAssoc -> = fixFix ops $ mkOp False opr (mkOp True opl a b) c -> | pr == pl && al == RightAssoc && ar == RightAssoc -> = fixFix ops $ mkOp False opl a (mkOp True opr b c) -> | otherwise = RError file line $ ":ambiguous operators, please add brackets" - -> mkOp t op l r = RUserInfix file line t op l r - - -Everything else, we ony work at the top level. - -> fixFix' _ x = x - -> (!!!) xs (x, msg) = if x >= length xs then error msg else xs!!x diff --git a/Idris/Compiler.lhs b/Idris/Compiler.lhs deleted file mode 100644 --- a/Idris/Compiler.lhs +++ /dev/null @@ -1,396 +0,0 @@ -> module Idris.Compiler(comp, addTransforms) where - -> import Idris.AbsSyntax -> import Idris.PMComp -> import Idris.LambdaLift -> import Idris.ConTrans -> import Idris.SCTrans -> import Idris.Lib -> import Ivor.TT hiding (transform, SimpleCase(..), CaseAlt(..)) - -> import System -> import System.IO -> import System.Environment -> import System.Directory -> import Monad -> import Debug.Trace - -Get every definition from the context. Convert them all to simple case -trees. Ignore constructors, types, etc. Simple definitions are, of course, -already simple case trees. - -> addTransforms :: IdrisState -> Context -> IdrisState -> addTransforms ist ctxt -> = let raw = idris_context ist -> erasure = not $ NoErasure `elem` (idris_options ist) -> ctrans = makeConTransforms raw ctxt -> atrans = makeArgTransforms raw ctxt ctrans -> trans = if erasure then makeIDTransforms raw ctxt atrans -> else [] in -> ist { idris_transforms = trans } - -> comp :: IdrisState -> Context -> Id -> FilePath -> IO Bool -> comp ist ctxt nm ofile -> = do let raw = idris_context ist -> let decls = idris_decls ist -> let erasure = not $ NoErasure `elem` (idris_options ist) -> let pdefs = getCompileDefs raw ctxt -> let trans = idris_transforms ist -> let vtrans = transforms (idris_fixities ist) -> let pcomp = map (pmCompDef raw ctxt erasure trans vtrans) pdefs -> let declouts = filter (/="") (map epicDecl decls) -> let clink = filter (/="") (map epicLink decls) -> -- dumpNames pcomp -> let scs = map (\ (n, inl, sc) -> (n, inl, transformSC erasure sc)) -> $ allSCs pcomp -> catch (do compileAll raw ctxt ofile erasure clink declouts scs -> return True) -> (\e -> do putStrLn "Compilation error" -> print e -> return False) -> where allSCs [] = [] -> allSCs ((x,gen,(args,def)):xs) -> = -- trace (show (x,args)) $ -> let lifted = lambdaLift ctxt ist x args def -> scfuns = map (\ (n,args,sc) -> -> (n, scFun ctxt ist (fromIvorName ist n) args sc)) lifted -> xs' = allSCs xs in -> mkGen gen scfuns ++ xs' -> mkGen gen ((n, d):ds) = (n,gen,d):(mkGen True ds) -> mkGen gen [] = [] - -Convert top level declarations to epic output. -This is just for the directives to link in C headers, .o file, etc. - -> epicDecl :: Decl -> String -> epicDecl (CInclude i) = "%include " ++ show i -> epicDecl _ = "" - -> epicLink :: Decl -> String -> epicLink (CLib l) = l -> epicLink _ = "" - -Get all the definitions we want to compile (i.e., skipping NoCG ones) - -Get the user specified pattern definition, if it exists, not the Ivor -expanded one (i.e. with the placeholders as the user specified) so -that we avoid pattern matching where the programmer didn't ask us to. - -> getCompileDefs :: Ctxt IvorFun -> Context -> [(Name, (ViewTerm, Patterns))] -> getCompileDefs raw ctxt = defs' [] (ctxtAlist raw) -> where alldefs = map getOrig (getAllPatternDefs ctxt) -> defs' acc [] = dropAll acc alldefs -> defs' acc ((n,ifun):ds) -> = let flags = funFlags ifun -> inm = toIvorName n in -> case (NoCG `elem` flags) of -> True -> {- trace ("Not compiling " ++ show n) -} -> defs' (inm:acc) ds -> _ -> defs' acc ds -> dropAll drops [] = [] -> dropAll drops ((n,def):ds) | n `elem` drops = dropAll drops ds -> | otherwise = (n,def):(dropAll drops ds) -> getOrig (n, (ty, ps)) = (n, (ty, ps)) - - = case ctxtLookup raw (mkRName n) of - (Just ifun) -> - case (ivorDef ifun) of - PattDef ps' -> (n, (ty, (mergePats ps ps'))) - _ -> (n, (ty, ps)) - _ -> (n, (ty, ps)) - -> mergePats :: Patterns -> Patterns -> Patterns -> mergePats (Patterns ps) (Patterns ps') = Patterns (mp ps ps') -> where -> mp [] [] = [] -> mp ((PClause a _ r):ps) ((PClause a' _ r'):ps') = -> (PClause a' [] r):(mp ps ps') - -> pmCompDef :: Ctxt IvorFun -> Context -> -> Bool -> -- erasure on -> [Transform] -> -- optimisations -> [(ViewTerm, ViewTerm)] -> -- user level transforms -> (Name, (ViewTerm, Patterns)) -> -> (Name, Bool, ([Name], SimpleCase)) -> pmCompDef raw ctxt erase ctrans vtrans (n, (ty,ps)) -> -- = let flags = getFlags n raw in -> -- case ((NoCG `elem` flags), (CGEval `elem` flags)) of -> -- (True, _) -> trace ("Not compiling " ++ show n) (n, []) -> -- (False, False)e -> -> = let transpm = transform ctxt ctrans vtrans n ps -> gen = isAuxPattern ctxt n -> compiledp = pmcomp raw ctxt erase n ty transpm in -> -- trace (if n == name "copyRecInt" then show n ++ "\n" ++ show compiledp else "") -> (n, gen, compiledp) - - where getFlags n raw = case ctxtLookup raw n of - Just i -> funFlags i - Nothing -> [] - - -> compileAll :: Ctxt IvorFun -> Context -> FilePath -> Bool -> -> [String] -> -- options to pass to epic -> [String] -> -- raw epic output -> [(Name, Bool, SCFun)] -> IO () -> compileAll raw ctxt ofile erasure clink outputs scs = do -> (efile, eH) <- tempfile -> prel <- readLibFile defaultLibPath "Prelude.e" -> hPutStrLn eH prel -> mapM_ (hPutStrLn eH) outputs -> -- dumpNames scs -> mapM_ (writeDef eH erasure) scs -> hClose eH -> let cmd = "epic " ++ efile ++ " -o " ++ ofile ++ -> " -checking 0 " ++ -> concat (map (' ':) clink) -> -- putStrLn cmd -> exit <- system cmd -> -- removeFile efile -> if (exit /= ExitSuccess) -> then fail "EPIC FAIL" -> else return () - -> quotename [] = "" -> quotename ('[':cs) = "_OB_"++quotename cs -> quotename (']':cs) = "_CB_"++quotename cs -> quotename ('.':cs) = "_NS_"++quotename cs -> quotename (c:cs) = c:(quotename cs) - -> dumpNames [] = return () -> dumpNames (x:xs) = do putStr "Name: " -> putStrLn ((\ (a, b, c) -> show a) x) -> dumpNames xs - -> writeDef :: Handle -> Bool -> (Name, Bool, SCFun) -> IO () -> writeDef h erasure (n,gen,(SCFun scopts args def)) = do -> -- putStrLn $ "Writing " ++ show n -> when (gen || elem SCInline scopts) $ hPutStr h "%inline " -> when (elem SCStrict scopts) $ hPutStr h "%strict " -> maybe (return ()) (\ c -> hPutStrLn h ("export " ++ show c ++ " ")) (getEName scopts) -> hPutStrLn h (quotename (show n) ++ " (" ++ list args ++ ") -> Any = \n" ++ -> writeSC n erasure def) -> -- putStrLn $ "Written " ++ show n -> where list [] = "" -> list [a] = quotename (show a) ++ " : Any" -> list (x:xs) = quotename (show x) ++ " : Any, " ++ list xs - -Write out a constructor name, turning constructors of IO commands into -the relevant IO operation - -> writeSC :: Name -> Bool -> SCBody -> String -> writeSC fname erasure b = writeSC' b where - -> list [] = "" -> list [a] = writeSC' a -> list (x:xs) = writeSC' x ++ ", " ++ list xs - -> writeSC' (SVar n) = quotename (show n) -> writeSC' (SCon n i) = writeCon n i ++ "()" -> writeSC' (SApp (SCon n i) (fn:args:[])) -> | n == ionamei "Foreign" = writeFCall fn erasure args fname -> writeSC' (SApp (SCon n i) (_:args)) -> | n == ionamei "WhileAcc" = writeCon n i ++ "(" ++ list args ++ ")" -> writeSC' (SApp (SCon n i) args) = writeCon n i ++ "(" ++ list args ++ ")" - -Fork is a special case, because its argument needs to be evaluated lazily -or it'll be evaluated by the time we run the thread! - -> writeSC' (SApp (SVar n) [arg]) -> | n == name "fork" = -> "fork(lazy("++writeSC' arg++"))" - -TMP HACK until we do coercions on primitives properly - -> | n == name "__toInt" = -> "__epic_toInt(" ++ writeSC' arg ++ ")" -> | n == name "__toString" = -> "__epic_toString(" ++ writeSC' arg ++ ")" -> | n == name "__floatToString" = -> "__epic_floatToString(" ++ writeSC' arg ++ ")" -> | n == name "__stringToFloat" = -> "__epic_stringToFloat(" ++ writeSC' arg ++ ")" -> | n == name "__charToInt" = -> writeSC' arg -> | n == name "__intToChar" = -> writeSC' arg -> | n == name "__strlen" = -> "__epic_strlen(" ++ writeSC' arg ++ ")" -> | n == name "unsafeNative" = -> "__epic_native(" ++ writeSC' arg ++ ")" - -HACK for explicit laziness, and marking effectfullness - -> writeSC' (SApp (SVar lazy) [_,v]) -> | lazy == name "__lazy" = -> "lazy(" ++ writeSC' v ++ ")" -> writeSC' (SApp (SVar effect) [_,v]) -> | effect == name "__effect" = -> "%effect(" ++ writeSC' v ++ ")" - -Manual allocation - -> writeSC' (SApp (SVar malloc) [_,b,v]) -> | malloc == name "malloc" = -> "%memory(%fixed," ++ writeSC' b ++ "," ++ writeSC' v ++ ")" - -Epic has if/then/else, so just use that - -> writeSC' (SApp (SVar ite) [_,v,SLazy t,SLazy e]) -> | ite == name "if_then_else" = -> writeSC' (SIf v t e) -> writeSC' (SApp (SVar ite) [_,v,t,e]) -> | ite == name "if_then_else" = -> writeSC' (SIf v t e) - -> writeSC' (SApp (SVar n) [arg1, arg2, arg3]) -> | n == name "__substr" = -> "__epic_substr("++writeSC' arg1++", " ++ writeSC' arg2 ++ ", " ++ -> writeSC' arg3 ++ ")" - -HACK for string equality - -> writeSC' (SApp (SVar n) [arg1, arg2]) -> | n == name "__strEq" = -> "__epic_streq("++writeSC' arg1++", " ++ writeSC' arg2 ++ ")" -> | n == name "__charEq" = -> "__epic_chareq("++writeSC' arg1++", " ++ writeSC' arg2 ++ ")" -> | n == name "__strLT" = -> "__epic_strlt("++writeSC' arg1++", " ++ writeSC' arg2 ++ ")" - -> | n == name "__strCons" = -> "__epic_strcons("++writeSC' arg1++", " ++ writeSC' arg2 ++ ")" -> | n == name "__strFind" = -> "__epic_strFind("++writeSC' arg1++", " ++ writeSC' arg2 ++ ")" - -> writeSC' (SApp (SVar n) [arg1]) -> | n == name "__strHead" = -> "__epic_strhead("++writeSC' arg1++ ")" -> | n == name "__strTail" = -> "__epic_strtail("++writeSC' arg1++ ")" -> | n == name "__strRev" = -> "__epic_strrev("++writeSC' arg1++ ")" - -> writeSC' (SApp b args) = "(" ++ writeSC' b ++")(" ++ list args ++ ")" -> where list [] = "" -> list [a] = writeSC' a -> list (x:xs) = writeSC' x ++ ", " ++ list xs -> writeSC' (SLet n val b) = "let " ++ quotename (show n) ++ " : Any = " ++ writeSC' val -> ++ " in (" ++ writeSC' b ++ ")" -> writeSC' (SCCase b alts@((SConstAlt _ _):_)) -> = writeConstAlts fname erasure (writeSC' b) alts -> writeSC' (SCCase b alts) = "case " ++ writeSC' b ++ " of { " ++ -> writeAlts fname erasure alts -> ++ "}" -> writeSC' (SIf x t e) = "(if (" ++ writeSC' x ++ ") then (" ++ -> writeSC' t ++ ") else (" ++ writeSC' e ++ "))" -> writeSC' (SIfZero x t e) = "(if (" ++ writeSC' x ++ "==0) then (" ++ -> writeSC' t ++ ") else (" ++ writeSC' e ++ "))" -> writeSC' (SInfix op l r) = boolOp erasure op (writeOp op (writeSC' l) (writeSC' r)) -> writeSC' (SConst c) = writeConst c -> writeSC' (SLazy b) = "lazy(" ++ writeSC' b ++ ")" -> writeSC' SUnit = "%unused" -> writeSC' SError = "error \"error\"" - -> writeCon :: Name -> Int -> String -> writeCon n i -> | n == ionamei "PutStr" = "__epic_putStr" -> | n == ionamei "GetStr" = "__epic_readStr" -> | n == ionamei "NewRef" = "__epic_newRef" -> | n == ionamei "ReadRef" = "__epic_readRef" -> | n == ionamei "WriteRef" = "__epic_writeRef" -> | n == ionamei "NewLock" = "__epic_newLock" -> | n == ionamei "DoLock" = "__epic_doLock" -> | n == ionamei "DoUnlock" = "__epic_doUnlock" -> | n == ionamei "Fork" = "__epic_fork" -> | n == ionamei "Within" = "__epic_within" -> | n == ionamei "While" = "%while" -> | n == ionamei "WhileAcc" = "%while" -> | otherwise = "Con " ++ show i - -> writeOp Concat l r = "__epic_append(" ++ l ++", " ++ r ++")" -> writeOp op l r = "(" ++ l ++ ") " ++ show op ++ " (" ++ r ++ ")" - -> boolOp erasure op c = if (not erasure) && (retBool op) then -> "__epic_bool(" ++ c ++ ")" else c -> where retBool OpLT = True -> retBool OpEq = True -> retBool OpLEq = True -> retBool OpGT = True -> retBool OpGEq = True -> retBool _ = False - -> writeAlts n e [] = "" -> writeAlts n e [a] = writeAlt n e a -> writeAlts n e (x:xs) = writeAlt n e x ++ " | " ++ writeAlts n e xs - -> writeAlt n e (SAlt _ t args b) = "Con " ++ show t ++ " (" ++ list args ++ ") -> " -> ++ writeSC n e b -> where list [] = "" -> list [a] = quotename (show a) ++ ":Any" -> list (x:xs) = quotename (show x) ++ ":Any, " ++ list xs -> writeAlt n e (SDefault b) = "Default -> " ++ writeSC n e b -> writeAlt n e _ = "Default -> error \"unhandled case in " ++ show n ++ "\"" - -> writeConstAlts n e b [] = "error \" unhandled case in " ++ show n ++ "\"" -> writeConstAlts n e b [a] = writeConstAlt n e b a -> writeConstAlts n e b (x:xs) = writeConstAlt n e b x ++ -> " else (" ++ writeConstAlts n e b xs ++ ")" - -> writeConstAlt n e b (SConstAlt (Num x) ret) -> = " if (" ++ b ++ " == " ++ show x ++") then (" -> ++ writeSC n e ret ++ ") " -> writeConstAlt n e b (SConstAlt (Str x) ret) -> = " if (__epic_streq(" ++ b ++ ", " ++ show x ++")) then (" -> ++ writeSC n e ret ++ ") " -> writeConstAlt n e b (SDefault ret) = writeSC n e ret - -Chars are just treated as Ints by the compiler, so convert here. - -> writeConst (Ch c) = show $ fromEnum c -> writeConst c = show c - -> writeFCall :: SCBody -> Bool -> SCBody -> Name -> String -> writeFCall (SApp (SCon ffun _) [SConst (Str fname),argtys,retty]) e arglist topname = -> "foreign " ++ fToEpic retty ++ " " ++ show fname ++ -> " (" ++ build (zip (extract arglist) (extract argtys)) ++ ")" -> where build [] = "" -> build [(x,ty)] = writeSC topname e x ++ ":" ++ (fToEpic ty) -> build ((x,ty):xs) = writeSC topname e x ++ ":" ++ (fToEpic ty) ++ -> ", " ++ build xs - -This'll work for FArgList and List, because the penultimate is always the -element and last is always the tail. Should therefore also work before and -after forcing optimisation... - -> extract (SCon _ 0) = [] -> extract (SApp (SCon _ 0) _) = [] -> extract (SApp (SCon _ 1) args) = (last (init args)): -> (extract (last args)) -> extract x = error (show x) -> exTy arg = fToEpic arg - -> writeFCall _ _ _ _ = error "Ill-formed foreign function call" - - -Convert a constructor application of type 'FType' to an epic type. Just do -this on tag, we know the type. Check 'FType' in io.idr. - -> fToEpic :: SCBody -> String -> fToEpic (SCon _ 0) = "Unit" -> fToEpic (SCon _ 1) = "Int" -> fToEpic (SCon _ 2) = "String" -> fToEpic (SCon _ 3) = "Ptr" -> fToEpic (SCon _ 4) = "Float" -> fToEpic _ = "Any" -- idris data type - -> tempfile :: IO (FilePath, Handle) -> tempfile = do env <- environment "TMPDIR" -> let dir = case env of -> Nothing -> "/tmp" -> (Just d) -> d -> openTempFile dir "idris" - -> environment :: String -> IO (Maybe String) -> environment x = catch (do e <- getEnv x -> return (Just e)) -> (\_ -> return Nothing) diff --git a/Idris/ConTrans.lhs b/Idris/ConTrans.lhs deleted file mode 100644 --- a/Idris/ConTrans.lhs +++ /dev/null @@ -1,540 +0,0 @@ -> {-# OPTIONS_GHC -fglasgow-exts #-} - -Apply Forcing/Detagging/Collapsing optimisations from Edwin Brady's thesis. - -> module Idris.ConTrans(makeConTransforms, makeArgTransforms, makeIDTransforms, -> applyTransforms, transform, rebuildTrans) where - -> import Idris.AbsSyntax -> import Ivor.TT hiding (transform) -> import qualified Ivor.ViewTerm(transform) - -> import Maybe -> import List - -> import Debug.Trace - -Algorithm is approximately: - -1. Make sure all constructors are fully applied. This means all transformations -will be uniform whether on LHS or RHS of pattern defs. -Also it means that any constructors which aren't fully applied on the LHS -of a pattern turn into '_' patterns. This is fine... -2. Generate transformation rules as ViewTerm transformations by applying -forcing, detagging and collapsing to every data structure. -3. Apply rules on LHS and RHS of all definitions. - -Do all this before any pattern match compilation or lambda lifting. - -To do this uniformly, turn a pattern def into an application of the lhs, -then turn it back into a pclause - -Also apply user level transforms (vts) at this stage. - -Throughout, we don't care about the bound arguments in a PClause any more, -so just ignore them. - -> transform :: Context -> [Transform] -> [(ViewTerm, ViewTerm)] -> -> Name -> Patterns -> Patterns -> transform ctxt ts vts n (Patterns ps) = Patterns $ (map doTrans ps) -> where doTrans (PClause args _ ret) -> = let lhs = apply (Name Unknown n) args -> lhs' = applyTransforms ctxt (filter lhsSafe ts) lhs -> ret' = applyTransforms ctxt ts (allTrans vts ret) -> args' = getFnArgs lhs' in -> PClause args' [] ret' -> doTrans (PWithClause prf args scr (Patterns pats)) -> = let pats' = Patterns $ (map doTrans pats) -> lhs = apply (Name Unknown n) args -> lhs' = applyTransforms ctxt ts lhs -> scr' = applyTransforms ctxt ts scr -> args' = getFnArgs lhs' in -> PWithClause prf args' scr' pats' - -HACK: better to have a flag when building the transform. FIXME! - -> lhsSafe (Trans nm _ _) = not (isSuffixOf "_ID" nm) - -> allTrans ts tm = foldl (\tm (l,r) -> Ivor.ViewTerm.transform l r tm) tm (ts++ts) - -Look at all the definitions in the context, and make the relevant constructor -transformations for forcing, detagging and collapsing. - -HACK: We do three passes, to pick up collapsible things from the last pass to -help. This still won't get everything right. -If Ivor returned things in the order they were defined this wouldn't -be necessary - better fix Ivor. - -> makeConTransforms :: Ctxt IvorFun -> Context -> [Transform] -> makeConTransforms raw ctxt -> = let pass1 = mkT' (getAllInductives ctxt) [] [] -> pass2 = mkT' (getAllInductives ctxt) [] pass1 in -> mkT' (getAllInductives ctxt) [] pass2 -> where mkT' [] acc p1 = acc -> mkT' (x:xs) acc p1 = mkT' xs ((makeTransform ctxt x (p1++acc))++acc) p1 - -Apply the constructor transforms before making the function transforms -so that we don't needlessly keep arguments dropped by forcing. - -> makeArgTransforms :: Ctxt IvorFun -> Context -> [Transform] -> [Transform] -> makeArgTransforms raw ctxt ctrans -> = let pass1 = mkP' (getRawPatternDefs raw ctxt) ctrans [] -> pass2 = mkP' (getRawPatternDefs raw ctxt) ctrans pass1 in -> mkP' (getRawPatternDefs raw ctxt) ctrans pass2 -> where mkP' [] acc p1 = acc -> mkP' (x:xs) acc p1 -> = mkP' xs ((makePTransform raw ctxt (ctrans++p1++acc) x)++acc) p1 - -Look for functions which have become identity functions as a result of previous -transforms - -> makeIDTransforms :: Ctxt IvorFun -> Context -> [Transform] -> [Transform] -> makeIDTransforms raw ctxt trans -> = mkP' (getRawPatternDefs raw ctxt) trans -> where mkP' [] acc = acc -> mkP' (x:xs) acc -> = mkP' xs ((makeIDTransform raw ctxt (trans++acc) x)++acc) - -Make all the transformations for a type - -Step 1. Forcing - On each constructor, find namess that appear constructor - guarded in that constructor's return type. Any argument with these - names is forceable. - If the type of the argument is collapsible, it's also forceable. - - If there's only one constructor left, of the form C x, transform it to just x. - (Relies on totality) - -Step 2: Detagging - Check if there is an argument position in the return type which has a - different constructor at the head on each constructor. If so, - remove the tags on all constructor. -Step 3: Collapsing - If the only remaining arguments in all constructors are recursive (i.e. - return the type we're working with) or themselves collapsible, - translate all to Unit. - If this doesn't apply, undo step 2. - -Using the transforms so far (in acc) - we can also eliminate arguments -which are themselves collapsible. - -> makeTransform :: Context -> (Name, Inductive) -> [Transform] -> [Transform] -> makeTransform ctxt (n, ity) acc -> = let cons = constructors ity -> detagin = (map (getFnArgs.getReturnType) (map snd cons)) -> forceable = nub (map (\ (x,y) -> (x, force ctxt y acc, Ivor.TT.getArgTypes y)) cons) -> detaggable = pdisjoint ctxt detagin -> recursive = nub (map (\ (x,y) -> (x, recArgs n y acc, Ivor.TT.getArgTypes y)) cons) -> collapsible = (detaggable && all droppedAll (combine forceable recursive)) || (n == name "Proof") -> nattable = isNat forceable recursive -> in -> -- trace (show n ++ " " ++ show (nattable) ++ " " ++ show (forceable, recursive)) $ -- FORCING \n\t" ++ show forceable) -> if collapsible then -> map (collapseTrans n) cons -> else mapMaybe (forceTrans nattable (length cons)) forceable - -Combine assumes constructors are in each list in the same order. Since they -were built the same way, this is okay. Just combines the forceable and -recursive arguments, so we can see if this gets all of them - -> where combine [] [] = [] -> combine ((con, d, all):cs) ((con',d',all'):cs') -> | con == con' = (con, nub (d++d'), all):(combine cs cs') -> droppedAll (con, d, args) = length d == length args - -Horrible hack, sorry. It's an easy way to tell if a constructor is -from a collapsible type... - -> isCollapsible x t = (show x++"_COLLAPSE") `elem` (transNames t) -> transNames = map tname -> where tname (Trans n _ _) = n - -> isNat :: [(Name, [Name], [(Name, ViewTerm)])] -> -> [(Name, [Name], [(Name, ViewTerm)])] -> -> Maybe (Name, Name) -> isNat force recs = nt' force recs [] where -> nt' [] [] acc = nattable' (sortBy cmprec acc) -> nt' ((f, fargs, targs):fs) ((r, rargs, _):rs) acc -> -- we know f = r, from how they were built -> = nt' fs rs ((f, length targs, length fargs, length rargs):acc) -> cmprec (_,_,_,x) (_,_,_,y) = compare x y - -Ordered by number of recursive arguments -If there's two constructors, one with 0 recursive arguments and all others -force, one with 1 recursive argument and all others force, it can be -transformed to Nat. - -> nattable' :: [(Name, Int, Int, Int)] -> Maybe (Name, Name) -> nattable' [(z, ztot, zforce, 0), (s, stot, sforce, 1)] -> | (ztot==zforce) && (stot-1 == sforce) -> = Just (z, s) -> nattable' _ = Nothing - -> collapseTrans :: Name -> (Name, ViewTerm) -> Transform -> collapseTrans n (c, ty) = Trans ((show n)++"_COLLAPSE") -> (Just (mkCollapseTrans n c ty (length (Ivor.TT.getArgTypes ty)))) -> (Just (Collapse n c ty (length (Ivor.TT.getArgTypes ty)))) - -> mkCollapseTrans n c ty num = mkCollapse num -> where mkCollapse num tm -> | Name nty con <- getApp tm -> = let args = getFnArgs tm in -> if con == c && length args == num then -> Placeholder -- lose the lot -> else tm -> mkCollapse _ tm = tm - -> forceTrans :: Maybe (Name, Name) -> Int -> -> (Name, [Name], [(Name, ViewTerm)]) -> Maybe Transform -> forceTrans Nothing _ (x, [], _) = Nothing -> forceTrans nat ncons (n, forced, tys) -> = Just (Trans ((show n)++"_FORCE") (Just (mkForceTrans nat ncons n forced tys (length tys))) (Just (Force nat ncons n forced tys (length tys)))) - -If a term is n applied to (length tys) arguments, change it to -n applied to arguments minus the ones in forceable positions - -> mkForceTrans nat ncons n forced tys num = mkForce num -> where mkForce num tm -> | Name nty con <- getApp tm -> = let fn = getApp tm -> args = getFnArgs tm -> nargs = zip (map fst tys) args in -> if con == n && length args == num then -> let app = forceapply ncons (Name nty (newname nat con)) -> (map snd (filter notForced nargs)) in -> -- trace (show (app, con, nargs)) -> app -> else tm -> mkForce _ tm = tm -> forceapply 1 _ [x] = x -> forceapply _ n args = apply n args -> notForced (f, tm) = not (f `elem` forced) -> newname Nothing n = n - -If the type has the shape of a Nat, transform the constructors. - -> newname (Just (z, s)) n | n == z = name "O" -> | n == s = name "S" - -Given a constructor type, return all the names bound in it which -need not be stored (i.e. need not be bound) - -> force :: Context -> ViewTerm -> [Transform] -> [Name] -> force ctxt tm acc = let rt = getReturnType tm -> atypes = Ivor.TT.getArgTypes tm -> rtargs = getFnArgs rt in -> nub $ concat (map conGuarded rtargs) ++ -> (map fst (filter collapse atypes)) -> where isVar n | elem n boundnames = True -> | otherwise = -> case nameType ctxt n of -> Right _ -> False -> _ -> True -> boundnames = map fst (Ivor.TT.getArgTypes tm) -> conGuarded t = cg [] t -> cg acc (Name Bound x) | isVar x = x:acc -- variable name -> cg acc (Name Free x) | isVar x = x:acc -- variable name -> cg acc (Name DataCon _) = acc -> cg acc (Name t x) = [] -> cg acc (App f a) = cg (acc++(cg [] a)) f -> cg acc _ = [] -> collapse (n, ty) -> | Name _ apn <- getApp ty -> = isCollapsible apn acc -> collapse _ = False - -Given a constructor type, return all the names bound in it which -are to recursive arguments of the datatype. -(TODO: Higher order recursive arguments too.) - -> recArgs :: Name -> ViewTerm -> [Transform] -> [Name] -> recArgs tyname tm trans = map fst (filter isRec (Ivor.TT.getArgTypes tm)) -> where isRec (n, ty) -> | Name _ apn <- getApp ty -> = apn == tyname || isCollapsible apn trans -> isRec _ = False - - -Return whether constructor types are pairwise disjoint in their indices ---- takes a list of indices for each constructor - -> pdisjoint :: Context -> [[ViewTerm]] -> Bool -> pdisjoint c [] = True -> pdisjoint c [x] = True -> pdisjoint c (x:xs) = pdisjoint c xs && (pdisjointWith x xs) -> where pdisjointWith x [] = True -> pdisjointWith x (y:ys) = disjoint (zip x y) && pdisjointWith x ys - -Is there an argument position with a different constructor at the head? - -> disjoint xs = or (map disjointCon xs) -> disjointCon (x, y) -> | Name _ xn <- getApp x -> , Name _ yn <- getApp y -> = case (nameType c xn, nameType c yn) of -> (Right DataCon, Right DataCon) -> -> if (xn /= yn) then True -> else disjoint (zip (getFnArgs x) (getFnArgs y)) -> _ -> False -> disjointCon _ = False - -If an argument position is a placeholder in all clauses in the idris -definition, and the corresponding argument position in the Ivor definition -is either a pattern or unused (modulo recursion), do this to it: - -[[x]] => x -[[complex term]] => _ - -> getPlaceholders :: Context -> Name -> Patterns -> Patterns -> [Int] -> getPlaceholders ctxt n (Patterns ps) (Patterns ivps) -> = getPlPos (noDiscriminate [0..(args ps)-1] ps) ps ivps -> where -> getPlPos acc [] [] = acc -> getPlPos acc ((PClause args _ r):ps) ((PClause args' _ r'):ps') -> = getPlPos (filter (plArg args args' r') acc) ps ps' -> getPlPos acc ((PWithClause _ args _ _):ps) ((PClause args' _ r'):ps') -> = getPlPos (filter (plArg args args' r') acc) ps ps' -> getPlPos acc (_:ps) (_:ps') -> = getPlPos acc ps ps' -> getPlPos acc p p' = error $ "getPlPos : " ++ show (n,acc,p,p') - -> plArg args args' r' x -> = x args ((PClause args _ r):_) = length args -> args ((PWithClause _ args _ (Patterns rest)):_) = length args -> args [] = 0 - -Remove argument positions from the list where those arguments are needed -to discriminate. i.e., make sure the patterns are still pairwise disjoint -after removing them. - -> noDiscriminate :: [Int] -> [PClause] -> [Int] -> noDiscriminate phs ps = indiscriminate phs (map pargs ps) -> where pargs (PClause args _ _) = args -> pargs (PWithClause _ args _ _) = args - -Drop argument x, from all patterns, see if they are still pairwise disjoint. -If so, x can remain a placeholder position. - -> indiscriminate (x:xs) pats -> = let pats' = map (blot x) pats -> ok = pdisjoint ctxt pats' in -> if ok then x:(indiscriminate xs pats') -- remove -> else indiscriminate xs pats -- don't remove -> indiscriminate [] _ = [] - -> blot i xs = take (i-1) xs ++ Placeholder:(drop (i+1) xs) - -> recGuard :: Int -> Name -> ViewTerm -> [Name] -> Bool - -z must be used only as part of the ith argument to a call to fn. Anywhere -else, it can't be dropped. - -> recGuard i fn ret zs = and (map (recGuard' i fn ret) zs) -> recGuard' i fn ret z -> | Left _ <- nameType ctxt z -> = let res = rgOK ret in -> -- trace ("GUARD " ++ show (i,fn,z,ret,res)) -> res -> where rgOK ap@(App f a) = nthOK (getApp ap) (getFnArgs ap) -> rgOK (Name _ x) = x /= z -> rgOK (Lambda _ _ sc) = rgOK sc -> rgOK (Let _ _ val sc) = rgOK val && rgOK sc -> rgOK _ = True - -> nthOK (Name _ x) args -> | x == fn = and (map nOK (zip [0..] args)) -> nthOK f args = rgOK f && (and (map rgOK args)) -> nOK (argno, arg) | argno == i = True -> nOK (_,arg) = rgOK arg -> recGuard' i fn ret z = True - -- trace ("GUARD OK " ++ show (i,fn,tm,ret)) True - -True -- Complex term, just drop it. - -> makePTransform :: Ctxt IvorFun -> Context -> [Transform] -> -> (Name, (ViewTerm, Patterns)) -> [Transform] -> makePTransform raw ctxt ctrans (n, (ty, patsin)) -> = let pats = transform ctxt ctrans [] n patsin in -> case getPatternDef ctxt n of -> Right (_, idpatsin) -> -> let idpats = transform ctxt ctrans [] n idpatsin -> numargs = args pats -> placeholders = getPlaceholders ctxt n pats idpats in -> -- trace (show (placeholders, n)) $ -> if (null placeholders) -> then [] -> else [Trans (show n ++ "_dropargs") -> (Just (mkDropTrans n ty placeholders numargs)) -> (Just (Drop n ty placeholders numargs))] -> _ -> [] -> where -> args (Patterns ((PClause args _ r):_)) = length args -> args _ = 0 - -> mkDropTrans n ty pls num = doDrop pls num where -> doDrop pls num tm -> | Name nty fname <- getApp tm -> = let fn = getApp tm -> args = getFnArgs tm in -> if fname == n && length args == num then -> apply (Name nty fname) -> (map (simplArg pls) (zip [0..] args)) -> else tm -> doDrop _ _ tm = tm -> -- simplArg pls (a, n@(Name _ _)) = n -> simplArg pls (a, t) | a `elem` pls = Placeholder -> | otherwise = t - -Look for arguments which are invariant across all patterns and calls. -If there's only one left, in position i, replace recursive calls with the -argument in position i. If the LHS and RHS of all patterns is the same in -the result, it's an identity function, so replace it with (id x) where x is -the argument in position i. - -> makeIDTransform :: Ctxt IvorFun -> Context -> [Transform] -> -> (Name, (ViewTerm, Patterns)) -> [Transform] -> makeIDTransform raw ctxt ctrans (n, (ty, patsin@(Patterns (_:_)))) -> = let Patterns pats = transform ctxt ctrans [] n patsin -> argpos = zip [0..] (arguments (pats!!!(0,"pats fail"))) -> keepArgs = [0..length argpos-1] \\ (invariants argpos (map arguments pats)) -> trans = Trans (show n ++ "_ID") -> (Just (mkIDTrans n keepArgs (length argpos))) -> Nothing -> stripInvs = map (stripInv trans) pats in -> -- trace (show (n,stripInvs)) $ -> if (all (idClause keepArgs) stripInvs) -> then [trans] else [] - -> where invariants :: [(Int, ViewTerm)] -> [[ViewTerm]] -> [Int] -> invariants invs [] = map fst invs -> invariants invs (x:xs) = invariants (checkInv invs (zip [0..] x)) xs - -> checkInv [] args = args -> checkInv ((p,a):invs) args -> = checkInv invs (filter (isNotInv p a) args) - -If the argument in the given position is not invariant, drop it. Otherwise -keep it, for now. (We're either looking at a different position, or it -is indeed invariant) - -> isNotInv p a (x,a') | p==x && a/=a' = False -> | otherwise = True - -> stripInv t (PClause args _ ret) = PClause args [] (doTrans t ret) -> stripInv t w = w -> idClause [k] t@(PClause args _ ret) | k idClause _ _ = False - -> makeIDTransform raw ctxt ctrans _ = [] - -> mkIDTrans n [keep] arity tm -> | Name nty fname <- getApp tm -> = let fn = getApp tm -> args = getFnArgs tm in -> if fname == n && length args == arity && keep args!!!(keep, "mkIDfail") -> else tm - -> mkIDTrans _ _ _ tm = tm - -Dangerous: doesn't take account of argument lengths. Top level function -is transformed anyway. - - mkIDTrans n [keep] arity tm@(Name nty fname) - = if fname == n then App (Name nty (name "id")) Placeholder else tm - - -Apply all transforms in order to a term, eta expanding constructors first. - -> applyTransforms :: Context -> [Transform] -> ViewTerm -> ViewTerm -> applyTransforms ctxt ts term -> = foldl (flip doTrans) (etaExpand ctxt term) ts - -> doTrans :: Transform -> ViewTerm -> ViewTerm -> doTrans (Trans nm (Just trans) _) tm = tr tm where -> tr tm = {- if (nm=="Next_FORCE") then (trace (show tm) (tr' tm)) else -} -> tr' tm -> tr' (App f a) = trans (App (tr f) (tr a)) -> tr' (Lambda v ty sc) = trans (Lambda v (tr ty) (tr sc)) -> tr' (Forall v ty sc) = trans (Forall v (tr ty) (tr sc)) -> tr' (Let v ty val sc) = trans (Let v (tr ty) (tr val) (tr sc)) -> tr' (Annotation a t) = Annotation a (tr t) -> tr' t = trans t - -> etaExpand :: Context -> ViewTerm -> ViewTerm -> etaExpand ctxt tm = ec tm -> where -> ec ap@(App f a) -> | Right (ar, con, args) <- needsExp (App f a) -> = etaExp ar con args -> ec ap@(App _ _) = let f = getApp ap -> args = getFnArgs ap in -> apply f (map ec args) -> ec (Lambda n ty sc) = Lambda n (ec ty) (ec sc) - -That's all the terms we care about. - -> ec x = x - -> needsExp ap = needsExp' ap [] -> needsExp' (App f a) as = needsExp' f ((ec a):as) -> needsExp' nm@(Name _ n) as -> = do ar <- getConstructorArity ctxt n -> if (ar == length as) then ttfail "FAIL" -> else Right (ar, nm, as) -> needsExp' _ _ = ttfail "FAIL" - -We don't care about the type on the lambda here, We'll never look at it -even when compiling, it's just for the sake of having constructors fully -applied. - -> etaExp ar con args -> = -- trace ("ETA " ++ show (ar,con,args)) $ -> let newargs = map (\n -> (toIvorName (MN "exp" n))) -> [1..(ar-(length args))] in -> addLam newargs (apply con (args++(map (Name Unknown) newargs))) -> addLam [] t = t -> addLam (n:ns) t = Lambda n Star (addLam ns t) - - -Get the type of the constructor, look for constructor guarded arguments -in the return type, strip them. - -If, in addition, there is an index with disjoint constructors *and* all -remaining arguments are recursive, transform all constructors to Unit. - - mkConTrans :: Ctxt IvorFun -> Context -> Name -> Name -> [Transform] - mkConTrans raw ctxt ty = - let Just cons = getConstructors ctxt ty - -Given a constructor name, return the names and types of the arguments -which are not removed - -> getRemaining :: Context -> Name -> [(Name, ViewTerm)] -> getRemaining = undefined - -Given a constructor name, the names of arguments it has, and the names -of arguments to keep, make a transformation rule. - -> mkTrans :: Name -> [Name] -> [Name] -> Transform -> mkTrans con args keep = Trans (show con ++ "_force") (Just trans) undefined -> where trans tm = let (f,fargs) = (getApp tm, getFnArgs tm) in -> (tCon f fargs tm) -> tCon fc@(Name _ fcon) fargs tm -> | con == fcon = if (length args == length fargs) -> then apply fc (dropArgs fargs args keep) -> else tm -> tCon _ _ t = t -> dropArgs (f:fs) (a:as) keep -> | a `elem` keep = f:(dropArgs fs as keep) -> | otherwise = dropArgs fs as keep -> dropArgs _ _ keep = [] -> - -> rebuildTrans :: TransData -> ViewTerm -> ViewTerm -> rebuildTrans (Force a b c d e f) = mkForceTrans a b c d e f -> rebuildTrans (Collapse a b c d) = mkCollapseTrans a b c d -> rebuildTrans (Drop a b c d) = mkDropTrans a b c d diff --git a/Idris/Context.lhs b/Idris/Context.lhs deleted file mode 100644 --- a/Idris/Context.lhs +++ /dev/null @@ -1,242 +0,0 @@ -> module Idris.Context(Ctxt, Id(..), addEntry, ctxtLookup, ctxtLookupName, -> ctxtAlist, newCtxt, appCtxt, alistCtxt, mkName, -> Err(..)) where - -> import Data.List -> import qualified Data.Map as Map -> import Control.Monad.Error - -> import Data.Binary -> import Data.Typeable -> import Control.Monad - -> import Char - -> import Debug.Trace - -> data Id = UN String | MN String Int | NS [Id] Id -- NS is decorated name -> deriving (Eq, Ord) - -> instance Show Id where -> show (UN s) = s -> show (MN s i) = "__" ++ s ++ "_" ++ show i -> show (NS ns n) = showSep ns ++ show n -> where showSep ns = concat (map ((++".").show) ns) - -> instance Binary Id where -> put (UN x) = do put (0 :: Word8) -> put x -> put (MN x i) = do put (1 :: Word8) -> put x; put i -> put (NS n i) = do put (2 :: Word8) -> put n; put i - -> get = do tag <- getWord8 -> case tag of -> 0 -> liftM UN get -> 1 -> liftM2 MN get get -> 2 -> liftM2 NS get get - -> type Dict k v = Map.Map k v - -Lifted this lot out since I had to change for backwards compatibility. - -> dictInsert :: Ord k => k -> v -> Dict k v -> Dict k v -> dictInsert = Map.insert -> dictElems = Map.elems -> dictAlist = Map.assocs -> dictEmpty = Map.empty - -> dictLookup :: Ord k => k -> Dict k v -> Maybe v -> dictLookup = Map.lookup - -Contexts containing names and type information A context is just a map -from a to b, but we'll keep it abstract in case we need or want -something better later - -Contexts are divided into namespaces. Entries are added either to a defined namespace, or -the global namespace. Lookup will look for names in the current namespace then the global -namespace, and report an error on ambiguous names. - -FIXME: Needs to be a map from names to all possibilities, which are then disambiguated. - - type Ctxt a = Dict [Id] [(Id, a)] - -We keep a context as an alist *and* a Dict. This is because we want to retain -ordering, have multiple entries, append *and* have fast lookup. Rather than -have a cleverer data structure, this is an easy way. - -> data Ctxt a = Ctxt { -> alist :: [(Id, a)], -- for retaining ordering -> cdict :: Dict Id [(Id, a)] -> } - -> instance Binary a => Binary (Ctxt a) where -> put (Ctxt a b) = do put a; put b -> get = liftM2 Ctxt get get - -> data Err = NoName Id -> | Ambiguous Id [Id] -> | WrongNamespace Id [Id] -> | OtherErr String - -> instance Show Err where -> show (NoName n) = "No such name " ++ show n -> show (Ambiguous n xs) = "Ambiguous name " ++ show n ++ " " ++ show xs -> show (WrongNamespace n ns) = show n ++ " not defined in namespace " ++ show (NS ns (UN "")) - -> instance Error Err where -> noMsg = OtherErr "Unknown error" -> strMsg s = OtherErr s - -All operations are passed a [Id], which is the namespace we are currently in. -[] is the outermost namespace. - -> mkName :: [Id] -> Id -> Id -> mkName [] name = name -> mkName ns name@(NS ns' x) = name -> mkName ns x = NS ns x - -> lastName :: Id -> Id -> lastName (NS ns i) = lastName i -> lastName x = x - -> globalNS :: Id -> Bool -> globalNS (NS [] _) = True -> globalNS (NS _ _) = False -> globalNS _ = True - -> currentNS :: [Id] -> Id -> Bool -> currentNS ns (NS ns' _) = ns == ns' -> currentNS _ _ = True -- used as a global name, okay if not ambiguous - -> getNS :: Id -> [Id] -> getNS (NS n _) = n -> getNS x = [x] - -> addToD :: Dict Id [(Id,a)] -> Id -> a -> Dict Id [(Id, a)] -> addToD d n v = case dictLookup (lastName n) d of -> Nothing -> dictInsert (lastName n) [(n,v)] d -> Just nvs -> case lookup n nvs of -> Nothing -> dictInsert (lastName n) ((n,v):nvs) d -> Just _ -> dictInsert (lastName n) ((n,v):(dropN n nvs)) d -> where dropN n [] = [] -> dropN n ((n',v):xs) | n == n' = xs -> | otherwise = (n',v):(dropN n xs) - -If the root of the given name n appears multiple times in the dictionary, -then only return a value if it's an exact match, otherwise issue an -ambiguous name error - -> lookupD :: Dict Id [(Id,a)] -> [Id] -> Id -> Either Err (a, Id) -> lookupD d ns n = case dictLookup (lastName n) d of -> Nothing -> Left (NoName n) -> Just [] -> Left (NoName n) -> Just [(n',v)] -> if (n==n' || currentNS ns n) then Right (v, n') -> else Left (WrongNamespace (lastName n) -> (getNS n)) -> Just xs -> case lookup n xs of -> Just v -> Right (v, n) -> Nothing -> Left (Ambiguous n (map fst xs)) - -> addEntry :: Ctxt a -> [Id] -> Id -> a -> Ctxt a -> addEntry (Ctxt ca cd) ns name val -> = let name' = mkName ns name in -> Ctxt ((name', val):ca) (addToD cd name' val) - -> ctxtLookupName :: (Show a) => Ctxt a -> [Id] -> Id -> Either Err (a, Id) -> ctxtLookupName (Ctxt _ d) ns n = lookupD d ns (mkName ns n) - -> ctxtLookup :: (Show a) => Ctxt a -> [Id] -> Id -> Either Err a -> ctxtLookup ctxt namespace k = case ctxtLookupName ctxt namespace k of -> Right (x, k) -> Right x -> Left err -> Left err - -> ctxtAlist :: Ctxt a -> [(Id,a)] -> ctxtAlist (Ctxt ca _) = reverse ca - -> alistCtxt :: [(Id, a)] -> Ctxt a -> alistCtxt a = Ctxt a (mkD dictEmpty a) where -> mkD acc [] = acc -> mkD acc ((n,v):ns) = mkD (addToD acc n v) ns - -> newCtxt = Ctxt [] dictEmpty - -> appCtxt :: Ctxt a -> Ctxt a -> Ctxt a -> appCtxt (Ctxt l _) (Ctxt r _) = alistCtxt (l++r) - - -> {- -> addEntry :: Ctxt a -> [Id] -> Id -> a -> Ctxt a -> addEntry ctxt using k v = let vs = cnames using ctxt in -> dictInsert using ((k,v):vs) ctxt - -If name is fully qualified, just look in the right namespace. -Otherwise, first look in current namespace, then in global namespace. - -> ctxtLookupName :: (Show a) => Ctxt a -> [Id] -> Id -> Either Err (a, Id) -> ctxtLookupName ctxt [] k -> = case lookup k (cnames [] ctxt) of -> Just v -> Right (v, k) -> _ -> Left "No such var" - -> cnames ns ctxt = case dictLookup ns ctxt of -> Just vs -> vs -> _ -> [] - -> ctxtLookup :: (Show a) => Ctxt a -> [Id] -> Id -> Either Err a -> ctxtLookup ctxt namespace k = case ctxtLookupName ctxt namespace k of -> Right (x, k) -> Right x -> Left err -> Left err - -> ctxtAlist :: Ctxt a -> [(Id,a)] -> ctxtAlist cs = reverse $ concat (Map.elems cs) - -> alistCtxt :: [(Id, a)] -> Ctxt a -> alistCtxt [] = newCtxt -> alistCtxt ((x,y):xs) = addEntry (alistCtxt xs) [] x y - -> newCtxt = dictEmpty - -> appCtxt :: Ctxt a -> Ctxt a -> Ctxt a -> appCtxt xs ys = app' (nub (Map.keys xs)++(Map.keys ys)) -> where app' [] = dictEmpty -> app' (n:ns) = let bothnames = (cnames n xs ++ cnames n ys) in -> dictInsert n bothnames (app' ns) -> -} - -We need to keep insertion order, because when we add to ivor, we'd better insert them in -dependency order. - -This doesn't quite work. We need a multimap or some other trickery, because things may be -declared, used, then defined with the same name, and that name has to map each time. - -> {- - -> type Ctxt a = Dict Id [(a, Int)] - -> type Err = String - -> addEntry :: Ctxt a -> Maybe Id -> Id -> a -> Ctxt a -> addEntry ctxt using k v = dictInsert k (v, Map.size ctxt) ctxt - -> ctxtLookupName :: (Show a) => Ctxt a -> Maybe Id -> Id -> Either Err (a, Id) -> ctxtLookupName ctxt namespace k = case dictLookup k ctxt of -> Just (x, _) -> Right (x, k) -> Nothing -> Left "No such var" - -> ctxtLookup :: (Show a) => Ctxt a -> Maybe Id -> Id -> Either Err a -> ctxtLookup ctxt namespace k = case ctxtLookupName ctxt namespace k of -> Right (x, k) -> Right x -> Left err -> Left err - -> ctxtAlist :: Ctxt a -> [(Id,a)] -> ctxtAlist xs = map (\ (x, (d, o)) -> (x, d)) $ sortBy dep (dictAlist xs) -> where dep (n, (def, o)) (n', (def', o')) = compare o o' - -> newCtxt = dictEmpty - -> appCtxt :: Ctxt a -> Ctxt a -> Ctxt a -> appCtxt xs ys = Map.union xs ys - -> -} diff --git a/Idris/Fontlock.lhs b/Idris/Fontlock.lhs deleted file mode 100644 --- a/Idris/Fontlock.lhs +++ /dev/null @@ -1,280 +0,0 @@ -> module Idris.Fontlock(htmlise,latexise) where - -> import Data.Char -> import List - -> import Idris.AbsSyntax -> import Idris.Lexer -> import Idris.Context - -> data Markup = DC | TC | FN | CM | VV | KW | ST | CH | LCM -> | BRK | SEC | SUBSEC -> | TITLE | AUTHOR | HTML | LATEX | None -> deriving Show - -> hclass DC = "datacon" -> hclass TC = "typecon" -> hclass FN = "function" -> hclass CM = "comment" -> hclass VV = "variable" -> hclass KW = "keyword" -> hclass ST = "string" -> hclass CH = "string" -> hclass _ = "" - -> mkMarkups :: Ctxt IvorFun -> [(String, Markup)] -> mkMarkups ctxt = map mkMarkup (map (\ (x,y) -> (x, rawDecl y)) (ctxtAlist ctxt)) - -> mkMarkup :: (Id, Decl) -> (String, Markup) -> mkMarkup (NS _ i, f) = mkMarkup (i, f) -> mkMarkup (n, Fun _ _) = (show n, FN) -> mkMarkup (n, Fwd _ _ _) = (show n, FN) -> mkMarkup (n, TermDef _ _ _) = (show n, FN) -> mkMarkup (n, Prf _ _) = (show n, FN) -> mkMarkup (n, DataDecl _) = (show n, TC) -> mkMarkup (n, Constructor) = (show n, DC) -> mkMarkup (n, _) = (show n, VV) - -> getMarkup :: String -> [(String, Markup)] -> Markup -> getMarkup x ms = case lookup x ms of -> Just m -> m -> Nothing -> VV - -> markupText :: [(String, Markup)] -> String -> [(Markup, String)] -> markupText ms ('-':'-':' ':'I':'G':'N':'O':'R':'E':xs) = endIgnore ms xs -> markupText ms ('-':'-':'\n':xs) = (BRK, ""):markupText ms xs -> markupText ms ('-':'-':' ':'S':'e':'c':'t':'i':'o':'n':':':' ':xs) -> = markupSECtoNewline SEC "" ms xs -> markupText ms ('-':'-':' ':'T':'i':'t':'l':'e':':':' ':xs) -> = markupSECtoNewline TITLE "" ms xs -> markupText ms ('-':'-':' ':'L':'a':'T':'e':'X':':':' ':xs) -> = markupSECtoNewline LATEX "" ms xs -> markupText ms ('-':'-':' ':'H':'T':'M':'L':':':' ':xs) -> = markupSECtoNewline HTML "" ms xs -> markupText ms ('-':'-':' ':'A':'u':'t':'h':'o':'r':':':' ':xs) -> = markupSECtoNewline AUTHOR "" ms xs -> markupText ms ('-':'-':' ':'S':'u':'b':'s':'e':'c':'t':'i':'o':'n':':':' ':xs) -> = markupSECtoNewline SUBSEC "" ms xs -> markupText ms ('-':'-':xs) = markupCMtoNewline "" ms xs -> markupText ms ('{':'-':'>':xs) = markupText ms xs -> markupText ms ('>':'-':'}':xs) = markupText ms xs -> markupText ms ('{':'-':'-':xs) = markupLCM "" ms xs -> markupText ms ('{':'-':xs) = markupCM "" ms xs -> markupText ms ('\'':c:'\'':xs) = (CH, ['\'',c,'\'']):markupText ms xs -> markupText ms ('"':xs) = markupString ms xs -> markupText ms ('%':xs) = markupSpecial ms xs -> markupText ms ('\t':xs) = (None, " "):markupText ms xs -> markupText ms (c:cs) -> | isAlpha c || c=='_' = markupVar ms (c:cs) -> markupText ms (c:cs) = (None, [c]):markupText ms cs - -> markupText ms [] = [] - -> keywords = ["proof","data","using","idiom","params","namespace","module", -> "import","export","inline","where","partial","syntax","lazy", -> "infix","infixl","infixr","do","refl","if","then","else","let", -> "in","return","include","exists", "with"] -> types = ["String","Int","Char","Float","Ptr","Lock","Handle","Set"] - -> markupSpecial ms cs = case span isAllowed cs of -> (var,rest) -> (None, '%':var):(markupText ms rest) - -> markupVar ms cs = case span isAllowed cs of -> (var,rest) -> if (var `elem` keywords) -> then (KW, var):(markupText ms rest) -> else if (var `elem` types) -> then (TC, var):(markupText ms rest) -> else (getMarkup var ms, var):(markupText ms rest) - -> markupCMtoNewline acc ms ('\n':xs) = (CM, "--"++reverse acc): -> markupText ms ('\n':xs) -> markupCMtoNewline acc ms (x:xs) = markupCMtoNewline (x:acc) ms xs -> markupCMtoNewline acc ms [] = (CM, "--"++reverse acc):[] - -> markupSECtoNewline sec acc ms ('\n':xs) = (sec, reverse acc): -> markupText ms ('\n':xs) -> markupSECtoNewline sec acc ms (x:xs) = markupSECtoNewline sec (x:acc) ms xs -> markupSECtoNewline sec acc ms [] = (sec, reverse acc):[] - -> markupCM acc ms ('-':'}':xs) = (CM, "{-"++reverse acc++"-}"):markupText ms xs -> markupCM acc ms (x:xs) = markupCM (x:acc) ms xs -> markupCM acc ms [] = (CM, "{-"++reverse acc):[] - -> markupLCM acc ms ('-':'-':'}':xs) = (LCM, reverse acc):markupText ms xs -> markupLCM acc ms (x:xs) = markupLCM (x:acc) ms xs -> markupLCM acc ms [] = (LCM, reverse acc):[] - -> endIgnore ms ('-':'-':' ':'S':'T':'A':'R':'T':'\n':xs) = markupText ms xs -> endIgnore ms (x:xs) = endIgnore ms xs -> endIgnore ms [] = [] - -> markupString ms xs = case getstr xs of -> Just (str, rest, nls) -> (ST, show str):markupText ms rest - -> htmlise :: Ctxt IvorFun -> FilePath -> FilePath -> Maybe FilePath -> IO () -> htmlise ctxt fp outf style -> = do txt <- readFile fp -> let ms = mkMarkups ctxt -> let mtxt = markupText ms txt -> writeFile outf (renderHTML fp style mtxt) - -> latexise :: Ctxt IvorFun -> FilePath -> FilePath -> IO () -> latexise ctxt fp outf = do txt <- readFile fp -> let ms = mkMarkups ctxt -> let mtxt = markupText ms txt -> writeFile outf (renderLatex mtxt) - -> skipnl :: [(Markup, String)] -> [(Markup, String)] -> skipnl ((None, "\n"):xs) = skipnl xs -> skipnl xs = xs - -> skipIfBrk :: [(Markup, String)] -> [(Markup, String)] -> skipIfBrk xs = si xs xs -> where si orig next@((BRK, _):xs) = next -> si orig next@((TITLE, _):xs) = next -> si orig next@((HTML, _):xs) = next -> si orig next@((LATEX, _):xs) = next -> si orig next@((AUTHOR, _):xs) = next -> si orig next@((SEC, _):xs) = next -> si orig next@((SUBSEC, _):xs) = next -> si orig next@((LCM, _):xs) = next -> si orig ((None, "\n"):xs) = si orig xs -> si orig _ = orig - -> renderHTML :: String -> Maybe String -> [(Markup, String)] -> String -> renderHTML title style ms = htmlHeader title style ++ -> "\n" ++ html (skipIfBrk ms) ++ "\n\n\n" -> where -> html [] = "" -> html ((None, "\n"):xs) = tHtml "\n" ++ html (skipIfBrk xs) -> html ((None, t):xs) = tHtml t ++ html xs -> html ((TITLE, t):xs) -> = "\n\n

" ++ t ++ "

\n\n" ++ html (skipnl xs) -> html ((HTML, t):xs) -> = "\n\n

" ++ t ++ "

\n\n" ++ html (skipnl xs) -> html ((LATEX, t):xs) -> = html (skipnl xs) -> html ((AUTHOR, t):xs) -> = "\n\n

" ++ t ++ "

\n\n" ++ -> "" ++ sechead xs ++ "\n\n" ++ html (skipnl xs) -> html ((SEC, t):xs) -> = "\n\n

" ++ t ++ "

\n\n" ++ html (skipnl xs) -> html ((SUBSEC, t):xs) -> = "\n\n

" ++ t ++ "

\n\n" ++ html (skipnl xs) -> html ((BRK, t):xs) = tHtml t ++ html xs -> html ((LCM, t):xs) = "\n\n

" ++ tpara 0 t ++ "

\n\n" ++ html (skipnl xs) -> html ((m, t):xs) = "" ++ tHtml t ++ -> "" ++ html xs -> tHtml = concat.(map th) - -> th ' ' = " " -> th '\n' = "
\n" -> th x = [x] - -> tpara l [] = "" -> tpara l ('"':xs) = case getstr xs of -> Just (str,rest,_) -> "" ++ tpara l str ++ "" ++ -> tpara l rest -> _ -> error xs -> tpara l ('U':'R':'L':'[':xs) = -> case span (/=']') xs of -> (url, ']':rest) -> "" ++ url ++ "" -> ++ tpara l rest -> tpara l ('\\':'/':xs) = '/':tpara l xs -> tpara l ('\\':'\\':xs) = '\\':tpara l xs -> tpara l ('\\':'"':xs) = '"':tpara l xs -> tpara l ('\\':'*':xs) = '*':tpara l xs -> tpara l ('/':xs) = -> case span (/='/') xs of -> (txt, '/':rest) -> "" ++ txt ++ "" ++ tpara l rest -> tpara l ('*':xs) = case span (=='*') xs of -> (_,rest) -> "
  • " ++ tpara l rest -> tpara l ('\n':'\n':'*':xs) = "
      \n" ++ tpara (l+1) ('*':xs) -> tpara l ('\n':'\n':xs) = "\n

      \n

      \n" ++ tpara l xs -> tpara l ('\n':'-':xs) = if (l>0) then "

    " ++ tpara (l-1) xs -> else "

    " ++ tpara l xs -> tpara l ('<':xs) = "<"++ tpara l xs -> tpara l (x:xs) = x:(tpara l xs) - -> htmlHeader title style -> = "" ++ -> "" ++ title ++ "\n" ++ -> defaultStyle style ++ "" - -> secname t = take 10 (filter isAlpha t) - -> getsecs [] = [] -> getsecs ((SEC,t):xs) = (""++ t ++ ""):(getsecs xs) -> getsecs (_:xs) = getsecs xs - -> sechead ms = let ss = getsecs ms in -> if null ss then "" -> else concat (intersperse " | " (getsecs ms)) ++ "
    " - -> defaultStyle Nothing -> = "" -> defaultStyle (Just s) = "" - -> renderLatex :: [(Markup, String)] -> String -> renderLatex ms = latexHeader ++ latex 0 (skipIfBrk ms) ++ "\n\n\\end{document}" -> where -> latex i [] = usev i -> latex i ((None, "\n"):xs) = "\n" ++ latex i (skipIfBrk xs) -> latex i ((None, t):xs) = t ++ latex i xs -> latex i ((BRK, t):xs) = usev i ++ startv (i+1) ++ latex (i+1) xs -> latex i ((TITLE, t):xs) = "\\title{" ++ t ++ "}\n" ++ latex i (skipnl xs) -> latex i ((HTML, t):xs) = latex i (skipnl xs) -> latex i ((AUTHOR, t):xs) = "\\author{" ++ t ++ "}\n\\maketitle\n\n" ++ startv i ++ latex i (skipnl xs) -> latex i ((SEC, t):xs) = usev i ++ "\\section{" ++ t ++ "}\n\n" ++ startv (i+1) ++ latex (i+1) (skipnl xs) -> latex i ((SUBSEC, t):xs) = usev i ++ "\\subsection{" ++ t ++ "}\n\n" ++ startv (i+1) ++ latex (i+1) (skipnl xs) -> latex i ((LCM, t):xs) = usev i ++ tpara 0 t ++ "\n\n" ++ startv (i+1) ++ latex (i+1) (skipnl xs) -> latex i ((LATEX, t):xs) = usev i ++ tpara 0 t ++ "\n\n" ++ startv (i+1) ++ latex (i+1) (skipnl xs) -> latex i ((m, t):xs) = "^" ++ show m ++ "@" ++ t ++ "!" -> ++ latex i xs - -> tpara l [] = "" -> tpara l ('"':xs) = case getstr xs of -> Just (str,rest,_) -> "\\texttt{" ++ tpara l str ++ "}" ++ -> tpara l rest -> tpara l ('U':'R':'L':'[':xs) = -> case span (/=']') xs of -> (url, ']':rest) -> "\\url{" ++ url ++ "}" ++ tpara l rest -> tpara l ('/':'/':xs) = '/':tpara l xs -> tpara l ('/':xs) = -> case span (/='/') xs of -> (txt, '/':rest) -> "\\emph{" ++ txt ++ "}" ++ tpara l rest -> (txt, rest) -> "\\emph{" ++ txt ++ "}" ++ tpara l rest -> tpara l ('~':xs) = "\\~{ }" ++ tpara l xs -> tpara l ('#':xs) = "\\#" ++ tpara l xs -> tpara l ('\n':'\n':'*':xs) = "\n\\begin{itemize}\n" ++ tpara (l+1) ('*':xs) -> tpara l ('\n':'-':xs) = if (l>0) then "\\end{itemize}" ++ tpara (l-1) xs -> else "\n\n" ++ tpara l xs -> tpara l ('*':xs) = case span (=='*') xs of -> (_,rest) -> "\\item " ++ tpara l rest -> tpara l (x:xs) = x:(tpara l xs) - -> usev i = "\n\\end{SaveVerbatim}\n\\BUseVerbatim{vbtm" ++ show i ++ "}\n\n" -> startv i = "\\begin{SaveVerbatim}[commandchars=^@!]{vbtm" ++ show i ++ "}\n\n" - - -> latexHeader = "\\documentclass[a4paper]{article}\n" ++ -> "\n\\usepackage{fancyvrb}\n\\usepackage{color}\n\\usepackage{url}\n\n\\begin{document}\n\n" ++ -> "\\newcommand{\\" ++ show DC ++ "}[1]{\\textcolor[rgb]{0.8,0,0}{#1}}\n" ++ -> "\\newcommand{\\" ++ show TC ++ "}[1]{\\textcolor[rgb]{0,0,0.8}{#1}}\n" ++ -> "\\newcommand{\\" ++ show FN ++ "}[1]{\\textcolor[rgb]{0,0.5,0}{#1}}\n" ++ -> "\\newcommand{\\" ++ show VV ++ "}[1]{\\textcolor[rgb]{0.5,0,0.5}{#1}}\n" ++ -> "\\newcommand{\\" ++ show CM ++ "}[1]{\\textcolor[rgb]{0.4,0.2,0.2}{#1}}\n" ++ -> "\\newcommand{\\" ++ show KW ++ "}[1]{\\textcolor[rgb]{0,0,0}{#1}}\n" ++ -> "\\newcommand{\\" ++ show ST ++ "}[1]{\\textcolor[rgb]{0.4,0.4,0.4}{#1}}\n" - diff --git a/Idris/LambdaLift.lhs b/Idris/LambdaLift.lhs deleted file mode 100644 --- a/Idris/LambdaLift.lhs +++ /dev/null @@ -1,322 +0,0 @@ -> {-# OPTIONS_GHC -fglasgow-exts #-} - -> module Idris.LambdaLift where - -> import Idris.AbsSyntax -> import Idris.PMComp -> import Ivor.TT hiding (SimpleCase(..), CaseAlt(..)) -> -> import Control.Monad.State -> import Data.Typeable -> import Debug.Trace -> import Maybe - -> import List - -This is the language we're converting directly into Epic code, and the -output of the lambda lifter - -SCFun is a top level function, with C export name, list of args, code for the body. - -> data SCFun = SCFun [SCOpt] [Name] SCBody -> deriving Show - -> data SCOpt = SCInline | SCStrict | SCExport String -> deriving (Show, Eq) - -> getEName [] = Nothing -> getEName (SCExport n : xs) = Just n -> getEName (_:xs) = getEName xs - -> data SCBody = SVar Name -> | SCon Name Int -> | SApp SCBody [SCBody] -> | SLet Name SCBody SCBody -> | SCCase SCBody [SCAlt] -> | SIf SCBody SCBody SCBody -> | SIfZero SCBody SCBody SCBody -> | SUnit -- for anything that has no runtime meaning, eg types -> | SInfix Op SCBody SCBody -> | SIOOp SCIO -> | SConst Constant -> | SLazy SCBody -> | SError -> deriving (Show, Eq) - -Case alternatives, could be a constructor (with tag), a constant, or -a default case - -> data SCAlt = SAlt Name Int [Name] SCBody -> | SConstAlt Constant SCBody -> | SDefault SCBody -> deriving (Show, Eq) - -It's useful to be able to sort alternatives by tag, for transformation -purposes, since once they're compiled order doesn't matter. - -> instance Ord SCAlt where -> compare (SAlt _ t _ _) (SAlt _ u _ _) = compare t u -> compare (SConstAlt c _) (SConstAlt d _) = compare c d -> compare (SDefault _) (SDefault _) = EQ -> compare (SAlt _ _ _ _) _ = LT -> compare (SConstAlt _ _) (SAlt _ _ _ _) = GT -> compare (SConstAlt _ _) (SDefault _) = LT -> compare (SDefault _) _ = GT - -Built-in IO operations - -> data SCIO = PutStr SCBody -> | GetStr -> | Fork SCBody -> | NewLock SCBody -> | DoLock SCBody -> | DoUnlock SCBody -> | NewRef -> | ReadRef SCBody -> | WriteRef SCBody SCBody -> deriving (Show, Eq) - -Any lambdas in the body need to be made functions in their own right, -with names in scope passed as arguments. - -We should try to collect sequences of lambdas, e.g. \x \y \z . e -and lift x,y,z all at once. - -We are assuming that all names are already unique, and we're not going -to be inventing any new variable names, just new function names. This -should be guaranteed in the underlying Ivor term. - -Inside every ViewTerm, pull out the new SCs and replace lambdas with -application of new SC. First step, just lift lambda out. - -Note that we're not fussy about maintaining types here (we've already broken -things by making the case trees anyway). It would, perhaps, be useful to keep -an eye on where the primitive types are though. - -LiftState carries the next name, and a list of new functions with -name, arguments, body - -> data LiftState = SCS Int [(Name, [Name], SimpleCase)] - -> lambdaLift :: Context -> IdrisState -> Name -> [Name] -> -> SimpleCase -> [(Name, [Name], SimpleCase)] -> lambdaLift ctxt ist root args sc -> = let -- scEta = expandCons ctxt sc -- Forcing does this! If we -> -- do it again, we undo some of the work forcing has done since -> -- we've reduced arity there. -> (body, SCS _ defs) = runState (liftSC args sc) (SCS 0 []) in -> addRoot root args body defs -> where liftSC env (SCase tm alts) = do tm' <- lift env tm -> alts' <- mapM (liftAlt env) alts -> return (SCase tm' (sort alts')) -> liftSC env (Tm t) = do t' <- lift env t -> return (Tm t') -> liftSC env x = return x - -> liftAlt env (Alt c i args sc) = do sc' <- liftSC (env++args) sc -> return (Alt c i args sc') -> liftAlt env (ConstAlt c sc) = do sc' <- liftSC env sc -> return (ConstAlt c sc') -> liftAlt env (Default sc) = do sc' <- liftSC env sc -> return (Default sc') - -First argument says whether to eta expand - -> lift env (Lambda n ty sc) = liftLam env [n] sc -> lift env (App f a) = do f' <- lift env f -> a' <- lift env a -> return (App f' a') - -> lift env (Let n ty val sc) = do val' <- lift env val -> sc' <- lift (n:env) sc -> return (Let n ty val' sc') -> lift env (Annotation a t) = do t' <- lift env t -> return (Annotation a t') -> -- and that's all the nested terms we care about -> lift env x = return x - -Hoover up all the arguments to nested lambdsa, and make a new function. -with env and newargs. Apply it to the environment only. - -FIXME: Invent a unique name for the lifted arg n. Epic can deal with it, but it's still -a bit unpleasant. - -> liftLam env newargs (Lambda n ty sc) -> = liftLam env (newargs++[n]) sc -> liftLam env newargs x = do -> x' <- lift (env++newargs) x -> newFn <- getNewSC -> -- new function is \ env newargs -> x' -> addFn newFn (env++newargs) (Tm x') -> -- new body is (newFn @ env) -> return (apply (Name Unknown newFn) -> (map (Name Unknown) env)) - -> getNewSC = do SCS i bs <- get -> put (SCS (i+1) bs) -> return (name (show (MN (show root) i))) - -> addFn name args body = do SCS i bs <- get -> put (SCS i ((name,args,body):bs)) - -We need to make sure all constructors are fully applied before we start - -> expandCons ctxt sc = ec' sc -> where -> ec' (Tm tm) = Tm (ec tm) -> ec' (SCase tm alts) = SCase (ec tm) (map ecalt alts) -> ec' x = x -> ecalt (Alt n i ns sc) = Alt n i ns (ec' sc) -> ecalt (ConstAlt c sc) = ConstAlt c (ec' sc) -> ecalt (Default sc) = Default (ec' sc) - -> ec ap@(App f a) -> | Right (ar, con, args) <- needsExp (App f a) -> = etaExp ar con args -> ec (App f a) = App f (ec a) -> ec (Lambda n ty sc) = Lambda n (ec ty) (ec sc) - -That's all the terms we care about. - -> ec x = x - -> needsExp ap = needsExp' ap [] -> needsExp' (App f a) as = needsExp' f ((ec a):as) -> needsExp' nm@(Name _ n) as -> = do ar <- getConstructorArity ctxt n -> if (ar == length as) then ttfail "FAIL" -> else Right (ar, nm, as) -> needsExp' _ _ = ttfail "FAIL" - -We don't care about the type on the lambda here, We'll never look at it -even when compiling, it's just for the sake of having constructors fully -applied. - -> etaExp ar con args -> = let newargs = map (\n -> (toIvorName (MN "exp" n))) -> [1..(ar-(length args))] in -> addLam newargs (apply con (args++(map (Name Unknown) newargs))) -> addLam [] t = t -> addLam (n:ns) t = Lambda n Star (addLam ns t) - -Second step, turn the lambda lifted SimpleCases into SCFuns, translating -IO operations and do notation as we go. Pass relevant function flags through - -> scFun :: Context -> IdrisState -> Id -> [Name] -> SimpleCase -> SCFun -> scFun ctxt ist fn args lifted = SCFun mkOpts args (toSC ctxt ist lifted) -> where mkOpts' = do ifn <- ctxtLookup (idris_context ist) [] fn -> let decl = rawDecl ifn -> let opts = if (null (lazyArgs ifn)) -> then [SCStrict] else [] -> return $ opts ++ mapMaybe mkSCOpt (funFlags ifn) -> {- exp <- case decl of -> Fun _ fls -> getExpFlag fls -> TermDef _ _ fls -> getExpFlag fls -> _ -> fail "" -} - -> mkOpts = case mkOpts' of -> Left _ -> [] -> Right x -> x - -> mkSCOpt (CExport str) = Just $ SCExport str -> mkSCOpt Inline = Just $ SCInline -> mkSCOpt _ = Nothing - -> class ToSC a where -> toSC :: Context -> IdrisState -> a -> SCBody - -> instance ToSC SimpleCase where -> toSC c ist ErrorCase = SError -> toSC c ist Impossible = SError -> toSC c ist (Tm vt) = toSC c ist vt -> toSC c ist (SCase vt alts) = SCCase (toSC c ist vt) (map toSCa alts) -> where toSCa (Alt n i ns sc) = SAlt n i ns (toSC c ist sc) -> toSCa (ConstAlt v sc) = SConstAlt v (toSC c ist sc) -> toSCa (Default sc) = SDefault (toSC c ist sc) - -> instance ToSC ViewTerm where -> toSC ctxt ist t = sc' t [] where -> sc' (Name ty n) args -> | n == toIvorName (UN "__Prove_Anything") -> -- we can't actually use this value! -> = SCon (toIvorName (UN "__FAKE")) 0 -> | n == toIvorName (UN "__Suspend_Disbelief") -- arbitrary refl -> = scapply ist (SCon (toIvorName (UN "refl")) 0) args -- can't actually use this either -> | ty == DataCon -> = case getConstructorTag ctxt n of -> Right i -> scapply ist (SCon n i) args -> | otherwise -> = case nameType ctxt n of -> Right TypeCon -> SUnit -> _ -> scapply ist (SVar n) args -> sc' (App f a) args = sc' f ((sc' a []):args) -> sc' (Let n ty val x) args -> = scapply ist (SLet n (sc' val []) (sc' x [])) args - -Chars are just treated as Ints by the compiler, so convert here. - -> sc' (Constant c) [] -> = case (cast c)::Maybe Int of -> Just i -> SConst (Num i) -> Nothing -> -> case (cast c)::Maybe String of -> Just s -> SConst (Str s) -> Nothing -> case (cast c)::Maybe Char of -> Just c -> SConst (Num (fromEnum c)) -> Nothing -> case (cast c)::Maybe Double of -> Just c -> SConst (Fl c) -> sc' (Annotation _ x) args = sc' x args -> sc' Placeholder args = SUnit -> sc' x args = SUnit -- no runtime meaning - -scapply deals with special cases for infix operators, IO, etc. - -> scapply :: IdrisState -> SCBody -> [SCBody] -> SCBody - -Infix operators - -> scapply ist (SVar n) [x,y] -> | Just op <- getOp n allOps = SInfix op x y -> scapply ist (SVar n) [_,_,_,_] -> | n == opFn JMEq = SUnit - - scapply ist (SVar n) [_,x,y] - | n == opFn OpEq = SInfix OpEq x y - -> scapply ist f [] = f - -> scapply ist (SVar n) args -> = let raw = idris_context ist in -> case ctxtLookup raw [] (fromIvorName ist n) of -> Left _ -> SApp (SVar n) args -> Right ifn -> let ia = implicitArgs ifn -> lz = lazyArgs ifn -> args' = makeLazy (map (ia+) lz) args in -> SApp (SVar n) args' -> scapply ist (SCon n i) args -> = let raw = idris_context ist in -> case ctxtLookup raw [] (fromIvorName ist n) of -> Left _ -> SApp (SCon n i) args -> Right ifn -> let ia = implicitArgs ifn -> lz = lazyArgs ifn -> args' = makeLazy (map (ia+) lz) args in -> SApp (SCon n i) args' - -Everything else - -> scapply ist f args = SApp f args - -> makeLazy :: [Int] -> [SCBody] -> [SCBody] -> makeLazy lz args = zipWith ml' -> (map (\x -> elem x lz) [0..(length args-1)]) args -> where ml' True arg = SLazy arg -> ml' False arg = arg - -> addRoot :: Name -> [Name] -> SimpleCase -> [(Name, [Name], SimpleCase)] -> -> [(Name, [Name], SimpleCase)] -> addRoot root [] body@(Tm (Name _ n)) defs = -> case lookupT n defs of -> Just (as,b) -> (root, as, b):defs -> _ -> (root, [], body):defs -> where lookupT n ds = lookup n (map (\ (x,y,z) -> (x, (y,z))) ds) -> addRoot root args body defs = (root, args, body):defs diff --git a/Idris/Latex.lhs b/Idris/Latex.lhs deleted file mode 100644 --- a/Idris/Latex.lhs +++ /dev/null @@ -1,151 +0,0 @@ -> {-# OPTIONS_GHC -fglasgow-exts #-} - -> module Idris.Latex(latexDump,latexDefs) where - -> import Idris.AbsSyntax -> import Debug.Trace - -> latexDefs :: [String] -> [(Id,String)] -> latexDefs [] = [] -> latexDefs (d:ds) = case span (/='=') d of -> (i,a:def) -> (UN i, def):(latexDefs ds) -> _ -> latexDefs ds - -> latexDump :: Ctxt IvorFun -> [(Id,String)] -> Id -> IO () -> latexDump ctxt defs nm = case ctxtLookup ctxt [] nm of -> Right fn -> putStrLn $ latex ctxt defs fn -> Left _ -> do putStrLn "No such name" -> return () - -> class LaTeX a where -> latex :: Ctxt IvorFun -> [(Id, String)] -> a -> String - -> instance LaTeX Id where -> latex ctxt defs n -> = case lookup n (defs++ldefs) of -> Just l -> l -> Nothing -> case ctxtLookup ctxt [] n of -> Right (IvorFun _ _ _ _ d _ _ _) -> ty d (show n) -> Left _ -> "\\VV{" ++ show n ++ "}" -> where ty (DataDecl _) n = "\\TC{" ++ n ++ "}" -> ty Constructor n = "\\DC{" ++ n ++ "}" -> ty _ n = "\\FN{" ++ n ++ "}" -> ldefs = case ctxtLookup ctxt [] (MN "latex" 0) of -> Right (IvorFun _ _ _ _ (LatexDefs ds) _ _ _) -> ds -> Left _ -> [] - -> instance LaTeX IvorFun where -> latex ctxt defs (IvorFun nm ty _ _ decl _ _ _) = latex ctxt defs decl - -> instance LaTeX Decl where -> latex ctxt defs (DataDecl (Datatype id ty cons _ _ _ _)) -> = "\\DM{\\AR{\n\\Data\\hg\\:" ++ -> latex ctxt defs id ++ "\\:\\Hab\\:\\AR{" ++ -> latex ctxt defs ty ++ "\\hg\\Where}\\\\ \n\\begin{array}{rl}\n" ++ -> conList (map (latex ctxt defs) cons) ++ -> "\\end{array}\n}}" -> where conList [] = "" -> conList [a] = " & " ++ a ++ "\n" -> conList (a:as) = " & " ++ a ++ "\\\\ \n \\mid" ++ conList as -> latex ctxt defs (Fun f _) = latex ctxt defs f -> latex ctxt defs (TermDef n tm _) = "\\DM{" ++ latex ctxt defs n ++ "\\:=\\:" ++ latex ctxt defs tm ++ "}" -> latex ctxt defs (Fwd n ty _) = "\\DM{" ++ latex ctxt defs n ++ "\\:\\Hab\\:\\AR{" ++ latex ctxt defs ty ++ "}}" -> latex ctxt defs _ = "Can't LaTeXify this" -> - -> instance LaTeX Function where -> latex ctxt defs (Function n ty clauses _ _) = -> "\\DM{\\AR{\n" ++ -> latex ctxt defs n ++ "\\:\\Hab\\:\\AR{" ++ latex ctxt defs ty ++ "}\\\\ \n" ++ -> latexClauses clauses ++ "}}" -> where latexClauses [] = "" -> latexClauses cs@((n,(RawClause lhs rhs)):_) = -> let arity = length (getRawArgs lhs) in -> "\\PA{" ++ concat (take arity (repeat "\\A")) ++ -> "}{" ++ -> concat (map (latex ctxt defs) cs) ++ "}" - -> instance LaTeX RawClause where -> latex ctxt defs (RawClause lhs rhs) -> = let args = getRawArgs lhs -> fn = getFn lhs in -> showArgs (fn:args) ++ " & \\Ret{" ++ -> latex ctxt defs rhs ++ "}\\\\ \n" -> where -> showArgs [] = "" -> showArgs (a:as) = " & " ++ bracket (latex ctxt defs a) ++ showArgs as -> bracket x | ':' `elem` x = "(" ++ x ++ ")" -> | otherwise = x - -Type/term pairs - -> instance (LaTeX a) => LaTeX (a,RawTerm) where -> latex ctxt defs (tm,ty) = latex ctxt defs tm ++ "\\:\\Hab\\:\\AR{" ++ latex ctxt defs ty ++ "}" - -Clauses - -> instance (LaTeX a) => LaTeX (a,RawClause) where -> latex ctxt defs (nm,clause) = latex ctxt defs clause - -Constants - -> instance LaTeX Constant where -> latex ctxt defs TYPE = "\\Type" -> latex ctxt defs StringType = "\\TC{String}" -> latex ctxt defs IntType = "\\TC{Int}" -> latex ctxt defs FloatType = "\\TC{Float}" -> latex ctxt defs (Builtin s) = "\\TC{" ++ s ++ "}" -> latex ctxt defs n = show n - -Main bit for terms - -> instance LaTeX RawTerm where -> latex ctxt defs tm = showP 10 tm where -> showP p (RVar _ _ (UN "__Unit") _) = "()" -> showP p (RVar _ _ (UN "__Empty") _) = "\\bottom" -> showP p (RVar _ _ i _) = latex ctxt defs i -> showP p RRefl = "\\DC{refl}" -> showP p RPlaceholder = "\\_" -> showP p (RApp _ _ f a) = bracket p 1 $ showP 1 f ++ "\\:" ++ showP 0 a -> showP p (RAppImp _ _ n f a) = showP 1 f -> showP p (RBind n (Lam ty) sc) -> = bracket p 2 $ -> "\\lambda\\VV{" ++ show n ++ "}." ++ showP 10 sc -> showP p (RBind n (Pi Ex _ ty) sc) -> | internal n -- hack for spotting unused names quickly! -> = bracket p 2 $ showP 1 ty ++ "\\to" ++ showP 10 sc -> | otherwise -> = bracket p 2 $ -> "(\\VV{" ++ show n ++ "} \\Hab " ++ showP 10 ty ++ ")\\to" ++ -> showP 10 sc -> where internal (UN ('_':'_':_)) = True -> internal (MN _ _) = True -> internal _ = False -> showP p (RBind n (Pi Im _ ty) sc) -> = bracket p 2 $ showP 10 sc -> showP p (RBind n (RLet val ty) sc) -> = bracket p 2 $ -> "\\LET:\\VV{" ++ show n ++ "}\\: = " ++ showP 10 val -> ++ "\\:\\IN\\:" ++ showP 10 sc -> showP p (RConst _ _ c) = latex ctxt defs c -> showP p (RInfix _ _ op l r) = bracket p 5 $ -> showP 4 l ++ show op ++ showP 4 r - -We want the closing bracket inside the \AR here, so it's on the right line, -hence the weird bracketing. - -> showP p (RDo ds) = (bracket p 2 $ -> "\\RW{do}\\:\\AR{" ++ -> concat (map (latex ctxt defs) ds)) ++ "}" -> -> showP _ x = show x -> bracket outer inner str | inner>outer = "("++str++")" -> | otherwise = str - -> instance LaTeX Do where -> latex ctxt defs (DoBinding _ _ n ty tm) -> = latex ctxt defs n ++ "\\leftarrow " ++ latex ctxt defs tm ++ -> "\\\\ \n" -> latex ctxt defs (DoExp _ _ tm) = latex ctxt defs tm ++ "\\\\ \n" - - diff --git a/Idris/Lexer.hs b/Idris/Lexer.hs deleted file mode 100644 --- a/Idris/Lexer.hs +++ /dev/null @@ -1,465 +0,0 @@ -module Idris.Lexer where - -import Data.Char -import Debug.Trace - -import Idris.AbsSyntax - -type LineNumber = Int - -type P a = String -> String -> LineNumber -> Fixities -> Result a - -getLineNo :: P LineNumber -getLineNo = \s fn l ops -> Success l - -getFileName :: P String -getFileName = \s fn l ops -> Success fn - -getContent :: P String -getContent = \s fn l ops -> Success s - -getOps :: P Fixities -getOps = \s fn l ops -> Success ops - -thenP :: P a -> (a -> P b) -> P b -m `thenP` k = \s fn l ops -> - case m s fn l ops of - Success a -> k a s fn l ops - Failure e f ln -> Failure e f ln - -returnP :: a -> P a -returnP a = \s fn l ops -> Success a - -failP :: String -> P a -failP err = \s fn l ops -> Failure err fn l - -catchP :: P a -> (String -> P a) -> P a -catchP m k = \s fn l ops -> - case m s fn l ops of - Success a -> Success a - Failure e f ln -> k e s fn l ops - -happyError :: P a -happyError = reportError "Parse error" - -reportError :: String -> P a -reportError err = getFileName `thenP` \fn -> - getLineNo `thenP` \line -> - getContent `thenP` \str -> - failP (fn ++ ":" ++ show line ++ ":" ++ err ++ - " - before " ++ take 80 str ++ "...") - -data Token - = TokenName Id - | TokenNSep - | TokenInfixName String - | TokenBrackName Id - | TokenString String - | TokenInt Int - | TokenFloat Double - | TokenChar Char - | TokenBool Bool - | TokenMetavar Id - | TokenIntType - | TokenCharType - | TokenBoolType - | TokenFloatType - | TokenStringType - | TokenHandleType - | TokenLockType - | TokenPtrType - | TokenDataType - | TokenCoDataType - | TokenInfix - | TokenInfixL - | TokenInfixR - | TokenParams - | TokenUsing - | TokenIdiom - | TokenNoElim - | TokenCollapsible - | TokenPartial - | TokenSyntax - | TokenLazy - | TokenStatic - | TokenWhere - | TokenWith - | TokenType - | TokenLType - | TokenLazyBracket - | TokenOB - | TokenCB - | TokenOCB - | TokenCCB - | TokenHashOB - | TokenLPair - | TokenRPair - | TokenOSB - | TokenCSB - | TokenOId - | TokenCId --- | TokenExists - | TokenConcat - | TokenTilde - | TokenPlus - | TokenMinus - | TokenTimes - | TokenDivide - | TokenEquals - | TokenOr - | TokenAnd - | TokenMightEqual - | TokenEQ - | TokenGE - | TokenLE - | TokenGT - | TokenLT - | TokenArrow - | TokenFatArrow - | TokenTransArrow - | TokenLeftArrow - | TokenColon - | TokenSemi - | TokenComma - | TokenTuple - | TokenBar - | TokenStars - | TokenDot - | TokenEllipsis - | TokenLambda - | TokenInclude - | TokenModule - | TokenNamespace - | TokenPublic - | TokenPrivate - | TokenAbstract - | TokenImport - | TokenExport - | TokenInline - | TokenDo - | TokenReturn - | TokenIf - | TokenThen - | TokenElse - | TokenLet - | TokenIn - | TokenRefl - | TokenEmptyType - | TokenUnitType - | TokenUnderscore - | TokenBang --- Tactics - | TokenProof - | TokenTryProof - | TokenIntro - | TokenRefine - | TokenExists - | TokenGeneralise - | TokenReflP - | TokenRewrite - | TokenRewriteAll - | TokenCompute - | TokenUnfold - | TokenUndo - | TokenInduction - | TokenFill - | TokenTrivial - | TokenSimpleSearch - | TokenMkTac - | TokenBelieve - | TokenUse - | TokenDecide - | TokenAbandon - | TokenProofTerm - | TokenQED --- Directives - | TokenLaTeX - | TokenNoCG - | TokenEval - | TokenSpec - | TokenFreeze - | TokenThaw - | TokenTransform - | TokenCInclude - | TokenCLib - | TokenHide - | TokenEOF - deriving (Show, Eq) - - -lexer :: (Token -> P a) -> P a -lexer cont [] = cont TokenEOF [] -lexer cont ('\n':cs) = \fn line -> lexer cont cs fn (line+1) --- empty type -lexer cont ('_':'|':'_':cs) = cont TokenEmptyType cs -lexer cont ('_':c:cs) | not (isAlpha c) && c/='_' = cont TokenUnderscore (c:cs) -lexer cont (c:cs) - | isSpace c = \fn line -> lexer cont cs fn line - | isAlpha c = lexVar cont (c:cs) - | isDigit c = lexNum cont (c:cs) - | c == '_' = lexVar cont (c:cs) --- unit type -lexer cont ('(':')':cs) = cont TokenUnitType cs -lexer cont ('"':cs) = lexString cont cs -lexer cont ('\'':cs) = lexChar cont cs -lexer cont ('{':'-':cs) = lexerEatComment 0 cont cs -lexer cont ('-':'-':cs) = lexerEatToNewline cont cs -lexer cont ('(':cs) = cont TokenOB cs -lexer cont (')':cs) = cont TokenCB cs -lexer cont ('{':c:cs) - | isAlpha c || c=='_' = lexBrackVar cont (c:cs) -lexer cont ('{':cs) = cont TokenOCB cs -lexer cont ('}':cs) = cont TokenCCB cs -lexer cont ('[':'|':cs) = cont TokenOId cs -lexer cont ('|':']':cs) = cont TokenCId cs -lexer cont ('[':cs) = cont TokenOSB cs -lexer cont (']':cs) = cont TokenCSB cs -lexer cont ('?':'=':cs) = cont TokenMightEqual cs -lexer cont (';':cs) = cont TokenSemi cs -lexer cont ('\\':cs) = cont TokenLambda cs -lexer cont ('#':'(':cs) = cont TokenHashOB cs --- lexer cont ('#':cs) = cont TokenType cs -lexer cont (',':cs) = cont TokenComma cs -lexer cont ('|':'(':cs) = cont TokenLazyBracket cs -lexer cont ('%':cs) = lexSpecial cont cs -lexer cont ('?':cs) = lexMeta cont cs -lexer cont (c:cs) | isOpPrefix c = lexOp cont (c:cs) -lexer cont (c:cs) = lexError c cs - -lexError c s l ops = failP (show l ++ ": Unrecognised token '" ++ [c] ++ "'\n") s l ops - -lexerEatComment nls cont ('-':'}':cs) - = \fn line -> lexer cont cs fn (line+nls) -lexerEatComment nls cont ('\n':cs) = lexerEatComment (nls+1) cont cs -lexerEatComment nls cont (c:cs) = lexerEatComment nls cont cs - -lexerEatToNewline cont ('\n':cs) - = \fn line -> lexer cont cs fn (line+1) -lexerEatToNewline cont [] - = \fn line -> lexer cont [] fn line -lexerEatToNewline cont (c:cs) = lexerEatToNewline cont cs - -lexNum cont cs = case readNum cs of - (num,rest,isreal) -> - cont (tok num isreal) rest - where tok num isreal | isreal = TokenFloat (read num) - | otherwise = TokenInt (read num) - -readNum :: String -> (String,String,Bool) -readNum x = rn' False "" x - where rn' dot acc [] = (acc,[],dot) - rn' False acc ('.':xs) | head xs /= '.' = rn' True (acc++".") xs - rn' dot acc (x:xs) | isDigit x = rn' dot (acc++[x]) xs - rn' dot acc ('e':'+':xs) = rn' True (acc++"e+") xs - rn' dot acc ('e':'-':xs) = rn' True (acc++"e-") xs - rn' dot acc ('e':xs) = rn' True (acc++"e") xs - rn' dot acc xs = (acc,xs,dot) - -lexString cont cs = - \fn line ops -> - case getstr cs of - Just (str,rest,nls) -> cont (TokenString str) rest fn (nls+line) ops - Nothing -> failP (fn++":"++show line++":Unterminated string contant") - cs fn line ops - -lexChar cont cs = - \fn line ops -> - case getchar cs of - Just (str,rest) -> cont (TokenChar str) rest fn line ops - Nothing -> - failP (fn++":"++show line++":Unterminated character constant") - cs fn line ops - -isAllowed c = isAlpha c || isDigit c || c `elem` "_\'?#." - -lexVar cont cs = - case span isAllowed cs of --- Keywords - ("proof",rest) -> cont TokenProof rest - ("tryproof",rest) -> cont TokenTryProof rest - ("data",rest) -> cont TokenDataType rest - ("codata",rest) -> cont TokenCoDataType rest - ("using",rest) -> cont TokenUsing rest - ("idiom",rest) -> cont TokenIdiom rest - ("params",rest) -> cont TokenParams rest - ("namespace",rest) -> cont TokenNamespace rest - ("public",rest) -> cont TokenPublic rest - ("private",rest) -> cont TokenPrivate rest - ("abstract",rest) -> cont TokenAbstract rest - ("module",rest) -> cont TokenModule rest - ("import",rest) -> cont TokenImport rest - ("export",rest) -> cont TokenExport rest - ("inline",rest) -> cont TokenInline rest - ("noElim",rest) -> cont TokenNoElim rest - ("collapsible",rest) -> cont TokenCollapsible rest - ("where",rest) -> cont TokenWhere rest - ("with",rest) -> cont TokenWith rest - ("partial",rest) -> cont TokenPartial rest - ("syntax",rest) -> cont TokenSyntax rest - ("lazy",rest) -> cont TokenLazy rest - ("static",rest) -> cont TokenStatic rest - ("infix",rest) -> cont TokenInfix rest - ("infixl",rest) -> cont TokenInfixL rest - ("infixr",rest) -> cont TokenInfixR rest - ("exists",rest) -> cont TokenExists rest --- Types - ("Set",rest) -> cont TokenType rest - ("LSet",rest) -> cont TokenLType rest - ("Int",rest) -> cont TokenIntType rest - ("Char",rest) -> cont TokenCharType rest - ("Float",rest) -> cont TokenFloatType rest - ("String",rest) -> cont TokenStringType rest - ("Lock",rest) -> cont TokenLockType rest - ("Handle",rest) -> cont TokenHandleType rest - ("Ptr",rest) -> cont TokenPtrType rest - ("refl",rest) -> cont TokenRefl rest - ("include",rest) -> cont TokenInclude rest - ("do",rest) -> cont TokenDo rest - ("return",rest) -> cont TokenReturn rest - ("if",rest) -> cont TokenIf rest - ("then",rest) -> cont TokenThen rest - ("else",rest) -> cont TokenElse rest - ("let",rest) -> cont TokenLet rest - ("in",rest) -> cont TokenIn rest --- values --- expressions - (var,rest) -> cont (mkname var) rest - -lexOp cont cs = case span isOpChar cs of - (":",rest) -> cont TokenColon rest --- ("+",rest) -> cont TokenPlus rest - ("-",rest) -> cont TokenMinus rest --- ("*",rest) -> cont TokenTimes rest --- ("/",rest) -> cont TokenDivide rest - ("=",rest) -> cont TokenEquals rest --- ("==",rest) -> cont TokenEQ rest - (">",rest) -> cont TokenGT rest - ("<",rest) -> cont TokenLT rest --- (">=",rest) -> cont TokenGE rest --- ("<=",rest) -> cont TokenLE rest --- ("++",rest) -> cont TokenConcat rest --- ("&&",rest) -> cont TokenAnd rest - ("<|",rest) -> cont TokenLPair rest - ("|>",rest) -> cont TokenRPair rest - ("&",rest) -> cont TokenTuple rest --- ("||",rest) -> cont TokenOr rest - ("...",rest) -> cont TokenEllipsis rest - ("**",rest) -> cont TokenStars rest - ("|",rest) -> cont TokenBar rest - ("!",rest) -> cont TokenBang rest - ("->", rest) -> cont TokenArrow rest - ("=>", rest) -> cont TokenFatArrow rest - -- ("==>", rest) -> cont TokenTransArrow rest - ("<-", rest) -> cont TokenLeftArrow rest - ("~", rest) -> cont TokenTilde rest - (op,rest) -> cont (TokenInfixName op) rest - -isOpPrefix c = c `elem` ":+-*/=_.?|&> cont (TokenBrackName (UN var)) rest - -lexSpecial cont cs = - case span isAllowed cs of - ("latex",rest) -> cont TokenLaTeX rest - ("nocg",rest) -> cont TokenNoCG rest - ("eval",rest) -> cont TokenEval rest - ("spec",rest) -> cont TokenSpec rest - ("freeze",rest) -> cont TokenFreeze rest - ("thaw",rest) -> cont TokenThaw rest - ("transform",rest) -> cont TokenTransform rest - ("include",rest) -> cont TokenCInclude rest - ("lib",rest) -> cont TokenCLib rest - ("hide",rest) -> cont TokenHide rest --- tactics --- FIXME: it'd be better to have a 'theorem proving' state so that these --- don't need the ugly syntax... - ("intro",rest) -> cont TokenIntro rest - ("refine",rest) -> cont TokenRefine rest - ("exists",rest) -> cont TokenExists rest - ("generalise",rest) -> cont TokenGeneralise rest - ("refl",rest) -> cont TokenReflP rest - ("rewrite",rest) -> cont TokenRewrite rest - ("rewriteall",rest) -> cont TokenRewriteAll rest - ("compute",rest) -> cont TokenCompute rest - ("unfold",rest) -> cont TokenUnfold rest - ("undo",rest) -> cont TokenUndo rest - ("induction",rest) -> cont TokenInduction rest - ("fill", rest) -> cont TokenFill rest - ("trivial", rest) -> cont TokenTrivial rest - ("searchcontext", rest) -> cont TokenSimpleSearch rest - ("mktac", rest) -> cont TokenMkTac rest - ("believe", rest) -> cont TokenBelieve rest - ("use", rest) -> cont TokenUse rest - ("decide", rest) -> cont TokenDecide rest - ("abandon", rest) -> cont TokenAbandon rest - ("prf", rest) -> cont TokenProofTerm rest - ("qed", rest) -> cont TokenQED rest - (thing,rest) -> lexError '%' rest - --- Read everything up to '[whitespace]Qed' -{- -lexProof cont cs = - \fn line -> - case getprf cs of - Just (str,rest,nls) -> cont (TokenProof str) rest fn (nls+line) - Nothing -> failP (fn++":"++show line++":No QED in Proof") - cs fn line --} - -lexMeta cont cs = - case span isAllowed cs of - (thing,rest) -> cont (TokenMetavar (UN thing)) rest - -mkname :: String -> Token -mkname c = TokenName (mkNS c) - -mkNS c = let xs = mkNS' [] [] c in - case xs of - [x] -> UN x - (x:xs) -> NS (map UN (reverse xs)) (UN x) - where - mkNS' acc wds [] = reverse acc:wds - mkNS' acc wds ('.':cs) = mkNS' [] (reverse acc:wds) cs - mkNS' acc wds (c:cs) = mkNS' (c:acc) wds cs - -getstr :: String -> Maybe (String,String,Int) -getstr cs = case getstr' "" cs 0 of - Just (str,rest,nls) -> Just (reverse str,rest,nls) - _ -> Nothing -getstr' acc ('\"':xs) = \nl -> Just (acc,xs,nl) -getstr' acc ('\\':'n':xs) = getstr' ('\n':acc) xs -- Newline -getstr' acc ('\\':'r':xs) = getstr' ('\r':acc) xs -- CR -getstr' acc ('\\':'t':xs) = getstr' ('\t':acc) xs -- Tab -getstr' acc ('\\':'b':xs) = getstr' ('\b':acc) xs -- Backspace -getstr' acc ('\\':'a':xs) = getstr' ('\a':acc) xs -- Alert -getstr' acc ('\\':'f':xs) = getstr' ('\f':acc) xs -- Formfeed -getstr' acc ('\\':'0':xs) = getstr' ('\0':acc) xs -- null -getstr' acc ('\\':x:xs) = getstr' (x:acc) xs -- Literal -getstr' acc ('\n':xs) = \nl ->getstr' ('\n':acc) xs (nl+1) -- Count the newline -getstr' acc (x:xs) = getstr' (x:acc) xs -getstr' _ _ = \nl -> Nothing - -getchar :: String -> Maybe (Char,String) -getchar ('\\':'n':'\'':xs) = Just ('\n',xs) -- Newline -getchar ('\\':'r':'\'':xs) = Just ('\r',xs) -- CR -getchar ('\\':'t':'\'':xs) = Just ('\t',xs) -- Tab -getchar ('\\':'b':'\'':xs) = Just ('\b',xs) -- Backspace -getchar ('\\':'a':'\'':xs) = Just ('\a',xs) -- Alert -getchar ('\\':'f':'\'':xs) = Just ('\f',xs) -- Formfeed -getchar ('\\':'0':'\'':xs) = Just ('\0',xs) -- null -getchar ('\\':x:'\'':xs) = Just (x,xs) -- Literal -getchar (x:'\'':xs) = Just (x,xs) -getchar _ = Nothing - -getprf :: String -> Maybe (String, String, Int) -getprf s = case getprf' "" s 0 of - Just (str,rest,nls) -> Just (reverse str,rest,nls) - _ -> Nothing -getprf' acc (c:'Q':'E':'D':rest) - | isSpace c = \nl -> Just (acc,rest,nl) -getprf' acc ('\n':xs) = \nl ->getprf' ('\n':acc) xs (nl+1) -- Count the newline -getprf' acc (x:xs) = getprf' (x:acc) xs -getprf' acc _ = \nl -> Nothing diff --git a/Idris/Lib.lhs b/Idris/Lib.lhs deleted file mode 100644 --- a/Idris/Lib.lhs +++ /dev/null @@ -1,15 +0,0 @@ -> {-# OPTIONS_GHC -fglasgow-exts #-} - -> module Idris.Lib(defaultLibPath, readLibFile) where - -> import Paths_idris - -> defaultLibPath = [] -- prefix ++ "/lib/idris"] - -> readLibFile :: [FilePath] -> FilePath -> IO String -> readLibFile xs x = -> do dfname <- getDataFileName x -> tryReads ((map (\f -> f ++ "/" ++ x) (".":xs))++[dfname]) -> where tryReads [] = fail $ "Can't find " ++ x -> tryReads (x:xs) = do catch (readFile x) -> (\e -> tryReads xs) diff --git a/Idris/MakeTerm.lhs b/Idris/MakeTerm.lhs deleted file mode 100644 --- a/Idris/MakeTerm.lhs +++ /dev/null @@ -1,418 +0,0 @@ -> module Idris.MakeTerm where - -> import Idris.AbsSyntax -> import Idris.Prover -> import Idris.SimpleCase -> import Idris.PartialEval - -> import Ivor.TT as TT -> import Debug.Trace - -> import Control.Monad -> import Control.Monad.State -> import List - -Work out how many implicit arguments we need, then translate our definition -into an ivor definition, with all the necessary placeholders added. - -The definition may generate new definitions (e.g. metavariables with proofs -attached). - -> makeIvorFun :: Implicit -> UndoInfo -> UserOps -> -> Ctxt IvorFun -> Decl -> Function -> [CGFlag] -> -> (IvorFun, [Decl]) - -> makeIvorFun using ui uo ctxt decl (Function n ty clauses file line) flags -> = let (rty, imp) = addImplWith using ctxt (syntax ctxt using uo ty) -> ity = makeIvorTerm using ui uo n ctxt rty -> extCtxt = addEntry ctxt (thisNamespace using) n (IvorFun Nothing (Just ity) -> imp Nothing decl flags (map (+p) (getLazy ty)) (map (+p) (getStatic ty))) -> clauses' = map (\ (n, c) -> (n, syntaxClause ctxt using uo c)) clauses -> (clausesm, (_, newms)) -> = runState (insertMetasClauses n clauses') (0, []) -> pclauses = map (mkPat extCtxt imp) clausesm -> newdefs = reverse (map mkPrf newms) in -> (IvorFun (Just (toIvorName (fullName using n))) -> (Just (Annotation (FileLoc file line) ity)) imp -> (Just (PattDef (Patterns pclauses))) decl flags -> (map (+p) (getLazy ty)) (map (+p) (getStatic ty)), -> newdefs) -> where p = length (params using) -> mkPat ectx imp (id,(RawClause lhs rhs)) -> = let lhs' = addPlaceholders ectx using uo lhs in -> case (getFn lhs', getRawArgs lhs') of -> (fid, pats) -> -> let vpats = map (toIvor uo ui n) pats -> vrhs = makeIvorTerm using ui uo n ectx rhs in -> PClause vpats [] vrhs -> mkPat ectx imp (id,(RawWithClause lhs prf scr def)) -> = let lhs' = addPlaceholders ectx using uo lhs in -> case (getFn lhs', getRawArgs lhs') of -> (fid, pats) -> -> let vpats = map (toIvor uo ui n) pats -> vscr = makeIvorTerm using ui uo n ectx scr -> vdef = Patterns $ map (mkPat ectx imp) (zip (repeat id) def) in -> PWithClause prf vpats vscr vdef -> mkPrf (nm, tacs, failable) = Prf (Proof nm Nothing tacs) failable - -> makeIvorFuns :: [Opt] -> Ctxt IvorFun -> -> [Decl] -> UserOps -> (Ctxt IvorFun, UserOps) -> makeIvorFuns opts is defs uo = mif opts is newCtxt noImplicit defDo uo defs - -> mif :: [Opt] -> -> Ctxt IvorFun -> -- init -> Ctxt IvorFun -> -- new -> Implicit -> -- implicits -> UndoInfo -> -- do using bind, return -> UserOps -> -- Users operators -> [Decl] -> (Ctxt IvorFun, UserOps) -> mif opt ctxt acc using ui uo [] = (acc, uo) -> mif opt ctxt acc using' ui uo ((Using using decls):ds) -> = let (acc', uo') = mif opt ctxt acc (addUsing using' (Imp using [] [] (thisNamespace using'))) ui uo decls in -> mif opt ctxt acc' using' ui uo' ds -> mif opt ctxt acc using' ui uo ((Params newps decls):ds) -> = let (acc', uo') = (mif opt ctxt acc (addParams using' newps) ui uo decls) in -> mif opt ctxt acc' using' ui uo' ds -> mif opt ctxt acc using' ui uo ((Namespace n decls):ds) -> = let (acc', uo') = (mif opt ctxt acc (addNS using' n) ui uo decls) in -> mif opt ctxt acc' using' ui uo' ds -> mif opt ctxt acc using ui@(UI _ _ _ _ p pi r ri) uo ((DoUsing bind ret decls):ds) -> = let (acc', uo') = (mif opt ctxt acc using ui' uo decls) in -> mif opt ctxt acc' using ui uo' ds -> where ui' = let (bimpl, bfull) -> = case ctxtLookupName (appCtxt ctxt acc) (thisNamespace using) bind of -> Right (i, bfull) -> (implicitArgs i, bfull) -> Left err -> error (show err) -> (rimpl, rfull) -> = case ctxtLookupName (appCtxt ctxt acc) (thisNamespace using) ret of -> Right (i, rfull) -> (implicitArgs i, rfull) -> Left err -> error (show err) -> in UI bfull bimpl rfull rimpl p pi r ri -> mif opt ctxt acc using ui@(UI b bi r ri _ _ _ _) uo ((Idiom pure ap decls):ds) -> = let (acc', uo') = (mif opt ctxt acc using ui' uo decls) in -> mif opt ctxt acc' using ui uo' ds -> where ui' = let (pureImpl, pfull) -> = case ctxtLookupName (appCtxt ctxt acc) (thisNamespace using) pure of -> Right (i, pfull) -> (implicitArgs i, pfull) -> Left err -> error (show err) -> (apImpl, afull) -> = case ctxtLookupName (appCtxt ctxt acc) (thisNamespace using) ap of -> Right (i, afull) -> (implicitArgs i, afull) -> Left err -> error (show err) -> in UI b bi r ri pfull pureImpl afull apImpl -> mif opt ctxt acc using' ui uo (decl@(Fun f flags):ds) -> = let using = addParamName using' (funId f) -> (fn, newdefs) = makeIvorFun using ui uo (appCtxt ctxt acc) decl f flags in -> mif opt ctxt (addEntry acc (thisNamespace using) (funId f) fn) using ui uo (newdefs ++ ds) -> mif opt ctxt acc using' ui uo (decl@(Fwd n ty flags):ds) -> = let (file, line) = getFileLine ty -> using = addParamName using' n -> (rty, imp) = addImplWith using (appCtxt ctxt acc) ty -> ity = makeIvorTerm using ui uo n (appCtxt ctxt acc) rty in -> mif opt ctxt (addEntry acc (thisNamespace using) n -> (IvorFun (Just (toIvorName (fullName using n))) -> (Just (Annotation (FileLoc file line) ity)) -> imp (Just Later) decl flags (getLazy ty) (getStatic ty))) using ui uo ds -> mif opt ctxt acc using' ui uo (decl@(DataDecl d):ds) -> = let using = addParamName using' (tyId d) in -> addDataEntries opt ctxt acc decl d using ui uo ds -- will call mif on ds -> mif opt ctxt acc using ui uo@(UO _ trans _ _) (decl@(TermDef n tm flags):ds) -> | null $ params using -> = let (itmraw, imp) = addImplWith using (appCtxt ctxt acc) tm -> itm = makeIvorTerm using ui uo n (appCtxt ctxt acc) itmraw in -> mif opt ctxt (addEntry acc (thisNamespace using) n -> (IvorFun (Just (toIvorName (fullName using n))) Nothing imp -> (Just (SimpleDef itm)) decl flags [] [])) using ui uo ds -> | otherwise = let (f,l) = getFileLine tm in -> mif opt ctxt (addEntry acc (thisNamespace using) n -> (IvorProblem (f ++ ":" ++ show l ++ ":" ++ -> show n ++ " needs a type declaration in a params block"))) -> using ui uo ds -> mif opt ctxt acc using ui uo (decl@(LatexDefs ls):ds) -> = mif opt ctxt (addEntry acc (thisNamespace using) (MN "latex" 0) -> (IvorFun Nothing Nothing 0 Nothing decl [] [] [])) using ui uo ds -> mif opt ctxt acc using ui (UO fix trans fr syns) (decl@(Fixity op assoc prec):ds) -> = mif opt ctxt (addEntry acc (thisNamespace using) (MN "fixity" (length ds)) -> (IvorFun Nothing Nothing 0 Nothing decl [] [] [])) using ui -> (UO ((op,(assoc,prec)):fix) trans fr syns) ds -> mif opt ctxt acc using ui uo@(UO fix trans fr syns) (decl@(Transform lhs rhs):ds) -> = let lhsraw = addPlaceholders (appCtxt ctxt acc) using uo lhs -> rhsraw = addPlaceholders (appCtxt ctxt acc) using uo rhs -> lhstm = makeIvorTerm using ui uo (MN "LHS" 0) ctxt lhsraw -> rhstm = makeIvorTerm using ui uo (MN "RHS" 0) ctxt rhsraw -> trans' = if (NoSpec `elem` opt) then trans else -> (lhstm,rhstm):trans in -> mif opt ctxt (addEntry acc (thisNamespace using) (MN "transform" (length ds)) -> (IvorFun Nothing Nothing 0 Nothing decl [] [] [])) using ui -> (UO fix trans' fr syns) ds -> mif opt ctxt acc using ui uo@(UO fix trans fr syns) (decl@(SynDef f args rhs):ds) -> = let sname = mkName (thisNamespace using) f -> syns' = addEntry syns (thisNamespace using) sname (Syntax sname args rhs) in -> mif opt ctxt (addEntry acc (thisNamespace using) f -> (IvorFun Nothing Nothing 0 Nothing decl [] [] [])) -> using ui (UO fix trans fr syns') ds - -Don't add yet! Or everything will be frozen in advance, rather than being -frozen after they are needed. - -> mif opt ctxt acc using ui uo@(UO fix trans fr syns) (decl@(Freeze _ _ _ _):ds) -> = mif opt ctxt (addEntry acc (thisNamespace using) (MN "freeze" (length ds)) -> (IvorFun Nothing Nothing 0 Nothing decl [] [] [])) using ui -> (UO fix trans fr syns) ds -> mif opt ctxt acc using ui uo (decl@(Prf (Proof n _ scr) failable):ds) -> = case ctxtLookup acc (thisNamespace using) n of -> Left _ -> -- add the script and process the type later, should -> -- be a metavariable -> mif opt ctxt (addEntry acc (thisNamespace using) n -> (IvorFun (Just (toIvorName (fullName using n))) Nothing 0 (Just (IProof scr failable)) decl [] [] [])) -> using ui uo ds -> Right (IvorFun _ ty imp _ _ _ _ _) -> -> mif opt ctxt (addEntry acc (thisNamespace using) n -> (IvorFun (Just (toIvorName (fullName using n))) ty imp (Just (IProof scr failable)) decl [] [] [])) -> using ui uo ds - -Just pass these on to epic to do the right thing - -> mif opt ctxt acc using ui uo ((CInclude _):ds) = mif opt ctxt acc using ui uo ds -> mif opt ctxt acc using ui uo ((CLib _):ds) = mif opt ctxt acc using ui uo ds -> mif opt ctxt acc using ui uo (d:ds) = error $ "Miffed: " ++ show d - -error "Not implemented" - -Add an entry for the type id and for each of the constructors. - -> addDataEntries :: [Opt] -> -> Ctxt IvorFun -> Ctxt IvorFun -> Decl -> -> Datatype -> Implicit -> -> UndoInfo -> UserOps -> -> [Decl] -> -> (Ctxt IvorFun, UserOps) -> addDataEntries opt ctxt acc decl (Latatype tid tty f l) using ui uo ds = -> let (tyraw, imp) = addImplWith using (appCtxt ctxt acc) tty -> tytm = Annotation (FileLoc f l) $ makeIvorTerm using ui uo tid (appCtxt ctxt acc) tyraw -> acc' = addEntry acc (thisNamespace using) tid -> (IvorFun (Just (toIvorName (fullName using tid))) (Just tytm) imp (Just LataDef) decl [] [] []) in -> mif opt ctxt acc' using ui uo ds -> addDataEntries opt ctxt acc decl (Datatype tid tty cons u e f l) using ui uo ds = -> let (tyraw, imp) = addImplWith using (appCtxt ctxt acc) tty -> tytm = Annotation (FileLoc f l) $ makeIvorTerm using ui uo tid (appCtxt ctxt acc) tyraw -> acctmp = addEntry (appCtxt ctxt acc) (thisNamespace using) tid -> (IvorFun (Just (toIvorName (fullName using tid))) (Just tytm) imp Nothing decl [] [] []) -> ddef = makeInductive acctmp tid (getBinders tytm []) cons -> (addUsing using (Imp u [] [] (thisNamespace using))) ui uo [] -> acc' = addEntry acc (thisNamespace using) tid -> (IvorFun (Just (toIvorName (fullName using tid))) (Just tytm) imp -> (Just (DataDef ddef (not (elem NoElim e)))) decl [] [] []) in -> addConEntries opt ctxt acc' cons u using ui uo ds f l - - Inductive (toIvorName tid) [] - -> makeInductive :: Ctxt IvorFun -> Id -> ([(Name, ViewTerm)], ViewTerm) -> -> [(Id,RawTerm)] -> Implicit -> -> UndoInfo -> UserOps -> [(Name, ViewTerm)] -> Inductive -> makeInductive ctxt tid (indices, tty) [] using ui uo acc -> = Inductive (toIvorName (fullName using tid)) [] indices tty (reverse acc) -> makeInductive ctxt cdec indices ((cid, cty):cs) using ui uo acc -> = let (tyraw, imp) = addImplWith using ctxt cty -> tytm = makeIvorTerm using ui uo cdec ctxt tyraw in -> makeInductive ctxt cdec -> indices cs using ui uo (((toIvorName (fullName using cid)),tytm):acc) - -Examine an inductive definition; any index position which does not -change across the structure becomes a parameter. - -The type has to be fully elaborated here. It's a bit of a hack, but we -add the type once, without the elim rule, so that the placeholders are filled -in, then we add it again after we work out what the parameters are, with -the elim rule. - -Parameters go at the left, so as soon as find find an argment which isn't -a parameter, there can be no more (or we mess up the declared type). Hence -'span' rather than 'partition'. - -> mkParams :: Inductive -> Inductive -> mkParams ind@(Inductive tname ps inds ty cons) -> = let (newps', newinds') = span (isParam (map snd cons)) -> (zip [0..] inds) -> newps = map snd newps' -> newinds = map snd newinds' -> newty = remAllPs newps ty -> newind = Inductive tname (ps++newps) newinds ty (remPs newps cons) in -> -- trace (show ind ++ "\n" ++ show newind ++ "\n" ++ show newps) $ -> newind -> where isParam [] _ = True -> isParam (c:cs) (pos, (n,ty)) -> | isParamCon pos c n = isParam cs (pos, (n,ty)) -> | otherwise = False - -If argument at given position wherever 'tname' is applied is always n, then -n is a parameter - -> isParamCon pos tm n -> = checkp pos n (getApps tm) -> checkp pos n [] = True -> checkp pos n (t:ts) -> | length t >= pos = nameMatch n (t!!!(pos,"checkp fail")) && checkp pos n ts -> | otherwise = False -> nameMatch n (Name _ nm) = n == nm -> nameMatch n (Annotation _ t) = nameMatch n t -> nameMatch _ _ = False - -> getApps app@(App f a) -> | appIsT (getApp f) = [getFnArgs app] -> | otherwise = getApps f ++ getApps a -> getApps (Forall n ty sc) = getApps ty ++ getApps sc -> getApps (Annotation _ n) = getApps n -> getApps x = [] - -> appIsT (Name _ n) = n == tname -> appIsT (Annotation _ t) = appIsT t -> appIsT _ = False - -> remPs newps [] = [] -> remPs newps ((n,ty):tys) = (n,remAllPs newps ty):(remPs newps tys) -> remAllPs newps (Forall n ty sc) -> | n `elem` (map fst newps) = remAllPs newps sc -> | otherwise = Forall n ty (remAllPs newps sc) -> remAllPs newps (Annotation _ n) = remAllPs newps n -> remAllPs newps x = x - -> addConEntries :: [Opt] -> -> Ctxt IvorFun -> Ctxt IvorFun -> -> [(Id,RawTerm)] -> -- constructors -> [(Id,RawTerm)] -> -- datatype local 'using' -> Implicit -> UndoInfo -> UserOps -> -- global 'using' -> [Decl] -> String -> Int -> -> (Ctxt IvorFun, UserOps) -> addConEntries opt ctxt acc [] u using ui uo ds f l = mif opt ctxt acc using ui uo ds -> addConEntries opt ctxt acc ((cid, ty):cs) u using' ui uo ds f l -> = let using = using' -- No! params are implicit here. addParamName using' cid -> (tyraw, imp) = addImplWith (addUsing (Imp u [] [] (thisNamespace using)) using) (appCtxt ctxt acc) ty -> tytm = Annotation (FileLoc f l) $ makeIvorTerm using ui uo cid (appCtxt ctxt acc) tyraw -> acc' = addEntry acc (thisNamespace using) cid -> (IvorFun (Just (toIvorName (fullName using cid))) (Just tytm) (imp+length (params using')) (Just IDataCon) Constructor [] (getLazy ty) (getStatic ty)) in -> addConEntries opt ctxt acc' cs u using ui uo ds f l - -Add definitions to the Ivor Context. Return the new context and a list -of things we need to define to complete the program (i.e. metavariables) - -> data TryAdd = OK (Context, [(Name, ViewTerm)]) UserOps StaticUsed -> | Err (Context, [(Name, ViewTerm)]) UserOps StaticUsed String -- record how far we got - -> addIvor :: [Opt] -> IdrisState -> -> Ctxt IvorFun -> -- all definitions, including prelude -> Ctxt IvorFun -> -- just the ones we haven't added to Ivor yet -> Context -> UserOps -> Statics -> StaticUsed -> TryAdd -> addIvor opts ist all defs ctxt uo sts stu -> = addivs (ctxt, []) uo stu (ctxtAlist defs) -> where addivs acc fixes stu [] = OK acc fixes stu -> addivs acc fixes stu ((n, IvorProblem err):ds) -> = Err acc fixes stu err -> addivs acc fixes stu (def@(_,ifn):ds) = -> case addIvorDef opts ist all fixes acc def sts stu of -> Right (ok, fixes, stu') -> addivs ok fixes stu' ds -> Left err -> Err acc fixes stu (idrisError all (guessContext ifn err)) - -Add a definition to Ivor. UserOps have been finalised already, by makeIvorFuns, -except frozen things, which need to be added as we go, in order. - -> addIvorDef :: [Opt] -> IdrisState -> -> Ctxt IvorFun -> UserOps -> (Context, [(Name, ViewTerm)]) -> -> (Id, IvorFun) -> Statics -> StaticUsed -> -> TTM ((Context, [(Name, ViewTerm)]), UserOps, StaticUsed) -> addIvorDef opt ist raw uo (ctxt, metas) (n,IvorFun name tyin _ def (LatexDefs _) _ _ _) sts stu -> = return ((ctxt, metas), uo, stu) -> addIvorDef opt ist raw (UO fix trans fr syns) (ctxt, metas) (n,IvorFun name tyin _ def f@(Fixity op assoc prec) _ _ _) sts stu -> = return ((ctxt, metas), UO fix trans fr syns, stu) -> addIvorDef opt ist raw (UO fix trans fr syns) (ctxt, metas) (n,IvorFun name tyin _ def f@(SynDef _ _ _) _ _ _) sts stu -> = return ((ctxt, metas), UO fix trans fr syns, stu) -> addIvorDef opt ist raw (UO fix trans fr syns) (ctxt, metas) (n,IvorFun name tyin _ def f@(Transform lhs rhs) _ _ _) sts stu -> = return ((ctxt, metas), UO fix trans fr syns, stu) -> addIvorDef opt ist raw (UO fix trans fr syns) (ctxt, metas) (n,IvorFun name tyin _ def f@(Freeze file line ns frfn) _ _ _) sts stu -> = case ctxtLookupName raw ns frfn of -> Right (_,fn') -> return ((ctxt, metas), UO fix trans (fn':fr) syns, stu) -> Left err -> Left (ErrContext (file ++ ":" ++ show line ++ ":") (Message (show err))) -> addIvorDef opt ist raw uo@(UO fix trans fr syns) (ctxt, metas) (n,IvorFun (Just name) tyin _ (Just def') _ flags lazy static) sts stu -> = let def = if (Verbose `elem` opt) -> then trace ("Processing " ++ show n) def' else def' in -> case def of -> PattDef ps -> -- trace (show (ps, getSpec flags fr)) $ -> do checkArgLengths (show n) ps -> (ctxt, newdefs) <- addPatternDefSC ctxt name (unjust tyin) ps (getSpec flags fr) sts -> -- Get the type checked version -> (_, pdef) <- getPatternDef ctxt name -> -- Generate some PE data from it -> -- let (_, nds, stu', newts, newfs) = getNewDefs n sts ist raw stu (PattDef pdef) -> -- (ctxt, uo, freeze) <- addPEdefs raw ctxt sts uo nds -> if (null newdefs) then return ((ctxt, metas), uo, stu) -> else do r <- addMeta (Verbose `elem` opt) raw ctxt metas newdefs -> return (r, uo, stu) -> -> SimpleDef tm -> -> do tm' <- case (getSpec flags fr) of -> Nothing -> return tm -> Just [] -> do ctm <- check ctxt tm -> let ans = view (evalnew ctxt ctm) -> return ans -> Just specfns -> do ctm <- check ctxt tm -> let ans = view (evalnewLimit ctxt ctm specfns) -> return ans -> ctxt <- case tyin of -> Nothing -> addDef ctxt name tm' -> Just ty -> addTypedDef ctxt name tm' ty -> -- Get the type checked version -> (_, pdef) <- getPatternDef ctxt name -> -- Generate some PE data from it -> let (_, nds, stu', newts, newfs) = getNewDefs n sts ist raw stu (PattDef pdef) -> (ctxt, uo, freeze) <- addPEdefs raw ctxt sts uo nds -> return ((ctxt, metas), uo, stu) -> LataDef -> case tyin of -> Just ty -> do ctxt <- declareData ctxt name ty -> return ((ctxt, metas), uo, stu) -> DataDef ind e -> -- trace (show (ind, e)) $ -> do c <- addDataNoElim ctxt ind -> -- add once to fill in placeholders -> ctxt <- if e then do -> d <- getInductive c name -> -- add again after we work out the parameters -> addData ctxt (mkParams d) -> else return c -> return ((ctxt, metas), uo, stu) -> -- addDataNoElim ctxt (mkParams d) -> -- trace (show (mkParams d)) $ return c -> IProof scr failable -> -> do case runScript raw ctxt uo n scr of -> Right ctxt -> do -> return ((ctxt, filter (\ (x,y) -> x /= toIvorName n) -> metas), uo, stu) - -If the proof doesn't work, but it was just a guess in a [tryproof ...] block, -just silently discard it and leave it for the user to fill in later: - -> Left err -> let ctxt' = if (Verbose `elem` opt) then -> trace (show n ++ " proof failed") ctxt else ctxt in -> if failable -> then return ((ctxt', metas), uo, stu) -> else Left err -> Later -> case tyin of -> Just ty -> do ctxt <- declare ctxt name ty -> return ((ctxt, metas), uo, stu) -> Nothing -> fail $ "No type given for forward declared " ++ show n -> _ -> return ((ctxt, metas), uo, stu) -> where unjust (Just x) = x -> getSpec [] fr -> = Nothing -> getSpec (CGEval:_) fr -> = Just (map (\x -> (toIvorName x, 0)) fr) -> getSpec (CGSpec ns:_) fr -> | NoSpec `elem` opt = Nothing -> | otherwise = Just $ (map (\ (x, i) -> (toIvorName x, i)) ns) ++ -> (map (\x -> (toIvorName x, 0)) fr) -> getSpec (_:ns) fr = getSpec ns fr - -> checkArgLengths :: String -> Patterns -> TTM () -> checkArgLengths n (Patterns cs) -> = if (length (nub (map (length.arguments) cs)) <= 1) -> then return () -> else ttfail $ "Differing numbers of arguments in clauses for " ++ n - diff --git a/Idris/PMComp.lhs b/Idris/PMComp.lhs deleted file mode 100644 --- a/Idris/PMComp.lhs +++ /dev/null @@ -1,405 +0,0 @@ -> {-# OPTIONS_GHC -fglasgow-exts #-} - -> module Idris.PMComp(pmcomp,SimpleCase(..),CaseAlt(..)) where - -Pattern matching compiler, convert to simple case expressions - -> import Idris.AbsSyntax -> import Ivor.TT hiding (SimpleCase(..), CaseAlt(..)) - -> import Data.Typeable -> import Debug.Trace -> import Control.Monad.State -> import List hiding (partition) - -Simple case statements are either a case analysis, just a term. ErrorCase -and Impossible are distinct in that 'Impossible' should be the default -fallthrough when a function is known to be total, and ErrorCAse otherwise. - -> data SimpleCase = SCase ViewTerm [CaseAlt] -> | Tm ViewTerm -> | ErrorCase -> | Impossible -> deriving (Show, Eq) - -> data CaseAlt = Alt Name Int [Name] SimpleCase -> | ConstAlt Constant SimpleCase -> | Default SimpleCase -> deriving (Show, Eq) - -> instance Ord CaseAlt where -> compare (Alt _ t _ _) (Alt _ u _ _) = compare t u -> compare (ConstAlt c _) (ConstAlt d _) = compare c d -> compare (Default _) (Default _) = EQ -> compare (Alt _ _ _ _) _ = LT -> compare (ConstAlt _ _) (Alt _ _ _ _) = GT -> compare (ConstAlt _ _) (Default _) = LT -> compare (Default _) _ = GT - -> data CS = CS Int - -> pmcomp :: Ctxt IvorFun -> Context -> -> Bool -> -- erasure on -> Name -> ViewTerm -> Patterns -> -> ([Name], SimpleCase) -> pmcomp raw ctxt erase n ty (Patterns ps) -> = pm' n (map mkPat (deIOpats erase ps)) -> where mkPat (PClause args _ rv) -> = Clause (map (toPat ctxt) args) rv -> pm' n ps = evalState (doCaseComp raw ctxt ps) (CS 0) - -It's easier if we can distinguish syntactically between constructor forms -and variables (and constants) - -> data Pat = PCon Name Int [Pat] -> | PVar Name -> | PConst Constant -> | PNK Name Constant -- n+k pattern -> | PAny -> deriving Show - -> data Clause = Clause [Pat] ViewTerm -> deriving Show - -FIXME: If an argument is repeated in the patterns, turn the later ones -into underscores (since type checking will verify they are the same, -and if we don't matching can get confused). - -> toPat :: Context -> ViewTerm -> Pat -> toPat ctxt tm = toPat' tm [] where -> toPat' (Name ty n) [] -> | ty /= DataCon = PVar n -> | isVar n = PVar n -> | not (isCon n) = PAny -> toPat' (Name DataCon n) args -> | isCon n = case getConstructorTag ctxt n of -> Right i -> PCon n i args -> Left _ -> error "Can't happen: no tag" -> | otherwise = error $ "Can't happen: variable applied to arguments " ++ show (n,args) -> toPat' (App (Name _ plus) (App (Name _ n) (Constant c))) [] -> | plus == opFn Plus -> = case (cast c)::Maybe Int of -> Just i -> PNK n (Num i) -> Nothing -> PAny -> toPat' (App f a) args = toPat' f ((toPat' a []):args) -> toPat' (Constant c) [] -> = case (cast c)::Maybe Int of -> Just i -> PConst (Num i) -> Nothing -> -> case (cast c)::Maybe String of -> Just s -> PConst (Str s) -> Nothing -> -> case (cast c)::Maybe Char of -> Just c -> PConst (Num (fromEnum c)) -> toPat' (Constant _) args -> = error "Can't happen: constant applied to arguments" -> toPat' _ _ = PAny - -> isVar n = case nameType ctxt n of -> Left _ -> True -> Right Bound -> True -> _ -> False -> isCon n = case nameType ctxt n of -> Right DataCon -> True -> _ -> False - -> isVarPat (Clause ((PVar _):ps) _) = True -> isVarPat (Clause (PAny:ps) _) = True -> isVarPat _ = False - -> isConPat (Clause ((PCon _ _ _):ps) _) = True -> isConPat (Clause ((PConst _):ps) _) = True -> isConPat _ = False - -> data Partition = Cons [Clause] -> | Vars [Clause] - -> partition :: Ctxt IvorFun -> Context -> [Clause] -> [Partition] -> partition raw ctxt [] = [] -> partition raw ctxt ms@(m:_) -> | isVarPat m = let (vars, rest) = span isVarPat ms in -> (Vars vars):partition raw ctxt rest -> | isConPat m = let (cons, rest) = span isConPat ms in -> (Cons cons):(partition raw ctxt rest) -> partition raw ctxt x = error (show x) - -> doCaseComp :: Ctxt IvorFun -> Context -> -> [Clause] -> State CS ([Name], SimpleCase) -> doCaseComp raw ctxt cs = do vs <- newVars cs -> let (cs', vs') = reOrder cs vs -> sc <- match raw ctxt (map mkVT vs') cs' ErrorCase -> -- return names in original order (this is the -> -- argument list we're making) -> return (map (name.show) vs, sc) -> where newVars [] = return [] -> newVars ((Clause ps _):_) -> = do CS i <- get -> put (CS (i+(length ps))) -> return $ map (MN "cvar") [i..(i+(length ps)-1)] -> mkVT x = Name Unknown (name (show x)) - -Reorder variables so that one with most disjoint cases is first. -(Actually, quick hack, just reverse them, since then the dependent things -will at least be looked at last, and we'll be matching on the real arguments -rather than indices.) - -> reOrder cs vs = let djs = (reverse.sort.(mapI 0 dj).transpose.allArgs) cs in -> (pickAll (map snd djs) cs, pick (map snd djs) vs) -> pickAll _ [] = [] -> pickAll djs ((Clause args rest):cs) -> = (Clause (pick djs args) rest):(pickAll djs cs) -> allArgs [] = [] -> allArgs ((Clause args rest):cs) = args:(allArgs cs) - -> pick [] _ = [] -> pick (i:is) xs = if (i else error ("ARGH! pick " ++ show (i,xs,cs)) - -Count the number of different constructor forms in xs - -> dj xs = dj' [] xs -> dj' acc [] = length (nub acc) -> dj' acc (PCon n i p:xs) = dj' (n:acc) xs -> dj' acc (_:xs) = dj' acc xs - -> mapI i f [] = [] -> mapI i f (x:xs) = (f x, i):(mapI (i+1) f xs) - -> match :: Ctxt IvorFun -> Context -> -> [ViewTerm] -> -- arguments -> [Clause] -> -- clauses -> SimpleCase -> -- fallthrough (error case) -> State CS SimpleCase -> match raw ctxt [] ((Clause [] ret):_) err -> = return $ Tm ret -- run out of arguments -> match raw ctxt vs cs err -> = mixture raw ctxt vs (partition raw ctxt cs) err - -> mixture :: Ctxt IvorFun -> Context -> -> [ViewTerm] -> -> [Partition] -> SimpleCase -> State CS SimpleCase -> mixture raw ctxt vs [] err = return err -> mixture raw ctxt vs ((Cons ms):ps) err -> = do fallthrough <- (mixture raw ctxt vs ps err) -> conRule raw ctxt vs ms fallthrough -> mixture raw ctxt vs ((Vars ms):ps) err -> = do fallthrough <- (mixture raw ctxt vs ps err) -> varRule raw ctxt vs ms fallthrough - -In the constructor rule: - -For each distinct constructor (or constant) create a group of possible -patterns in ConType and Group - -> data ConType = CName Name Int -- ordinary named constructor -> | CConst Constant -- constant pattern -> deriving (Show, Eq) - -> data Group = ConGroup ConType -- constructor -> -- arguments and rest of alternative for each instance -> [([Pat], Clause)] -> deriving Show - - -> conRule :: Ctxt IvorFun -> Context -> [ViewTerm] -> -> [Clause] -> SimpleCase -> State CS SimpleCase -> conRule raw ctxt (v:vs) cs err = -> do groups <- groupCons cs -> caseGroups raw ctxt (v:vs) groups err - -> caseGroups :: Ctxt IvorFun -> Context -> [ViewTerm] -> -> [Group] -> SimpleCase -> -> State CS SimpleCase -> caseGroups raw ctxt (v:vs) gs err -> = do g <- altGroups gs -> return $ SCase v g -> where altGroups [] = return [Default err] -> altGroups ((ConGroup (CName n i) args):cs) -> = do g <- altGroup n i args -> rest <- altGroups cs -> return (g:rest) -> altGroups ((ConGroup (CConst cval) args):cs) -> = do g <- altConstGroup cval args -> rest <- altGroups cs -> return (g:rest) - -> altGroup n i gs -> = do (newArgs, nextCs) <- argsToAlt gs -> matchCs <- match raw ctxt (map (Name Unknown) newArgs++vs) -> nextCs err -> return $ Alt n i newArgs matchCs -> altConstGroup n gs -> = do (_, nextCs) <- argsToAlt gs -> matchCs <- match raw ctxt vs nextCs err -> return $ ConstAlt n matchCs - -Find out how many new arguments we need to generate for the next step -of matching (since we're going to be matching further on the arguments -of each group for the constructor, and we'll need to give them names) - -Return the new variables we've added to do case analysis on, and the -new set of clauses to match. - -> argsToAlt :: [([Pat], Clause)] -> State CS ([Name], [Clause]) -> argsToAlt [] = return ([],[]) -> argsToAlt rs@((r,m):_) -> = do newArgs <- getNewVars r -> -- generate new match alternatives, by combining the arguments -> -- matched on the constructor with the rest of the clause -> return (newArgs, addRs rs) -> where getNewVars [] = return [] -> getNewVars ((PVar n):ns) = do nsv <- getNewVars ns -> return (n:nsv) -> getNewVars (_:ns) = do v <- getVar -> nsv <- getNewVars ns -> return (v:nsv) -> addRs [] = [] -> addRs ((r,(Clause ps res) ):rs) -> = (Clause (r++ps) res):(addRs rs) - -> getVar :: State CS Name -> getVar = do (CS var) <- get -> put (CS (var+1)) -> return (name (show (MN "pvar" var))) - -> groupCons :: Monad m => [Clause] -> m [Group] -> groupCons cs = gc [] cs -> where gc acc [] = return acc -> gc acc ((Clause (p:ps) res):cs) = do -> acc' <- addGroup p ps res acc -> gc acc' cs - -> addGroup p ps res acc = case p of -> PCon con i args -> return $ addg con i args (Clause ps res) acc -> PConst cval -> return $ addConG cval (Clause ps res) acc -> pat -> fail $ show pat ++ " is not a constructor or constant (can't happen)" - -> addg con i conargs res [] -> = [ConGroup (CName con i) [(conargs, res)]] -> addg con i conargs res (g@(ConGroup (CName n j) cs):gs) -> | i == j = (ConGroup (CName n i) (cs ++ [(conargs, res)])):gs -> | otherwise = g:(addg con i conargs res gs) - -> addConG con res [] = [ConGroup (CConst con) [([],res)]] -> addConG con res (g@(ConGroup (CConst n) cs):gs) -> | con == n = (ConGroup (CConst n) (cs ++ [([], res)])):gs -> | otherwise = g:(addConG con res gs) - -In the variable rule: - -case v args of - p pats -> r1 - ... - pn patsn -> rn - -====> - -case args of - pats -> r1[p/v] - ... - patsn -> rn[p/v] - -> varRule :: Ctxt IvorFun -> Context -> [ViewTerm] -> -> [Clause] -> SimpleCase -> State CS SimpleCase -> varRule raw ctxt (v:vs) alts err = do -> let alts' = map (repVar v) alts -> match raw ctxt vs alts' err -> where repVar v (Clause ((PVar p):ps) res) -> = let nres = subst p v res in -> {- trace (show v ++ " for " ++ dbgshow p ++ " in " ++ show res ++ " gives " ++ show nres) $ -} -> Clause ps nres -> repVar v (Clause (PAny:ps) res) = Clause ps res - - - -Remove IO gubbins, make actions and ordering explicit - -bind : IO A -> (A -> IO B) -> IO B -becomes -bind : A -> (A -> B) -> B - -bind _ _ val fn ==> let newv = [[val]] - in [[fn newv]] - -similarly for unsafeBind -unsafePerformIO becomes id - -IOReturn _ a ==> [[a]] -IODo _ c k ==> [[k]] [[c]] - -FIXME: Currently requires bind, iodo, etc to be fully applied. Need -intermediate functions for when this isn't the case - -> bname i = name (show (MN "bname" i)) - -We don't care about the bound argument names any more, so don't bother deIOing -them, just put an empty list in. - -> deIOpats :: Bool -> [PClause] -> [PClause] -> deIOpats erase cs = evalState (dp cs) 0 -> where dp [] = return [] -> dp ((PClause args _ rv):ps) = do args' <- mapM (deIO erase) args -> rv' <- deIO erase rv -> ps' <- dp ps -> return ((PClause args' [] rv'):ps') - -> deIO :: Bool -> ViewTerm -> State Int ViewTerm -> deIO erase t = deIO' t where - -> deIO' (App (App (App (App (Name _ bind) _) _) v) k) -> | bind == bindNamei || -> bind == ibindNamei -> = do i <- get -> put (i+1) -> v' <- deIO' v -> k' <- deIO' k -> return $ Let (bname i) Star -- type irrelevant -> (App (App (Name Unknown (name "__effect")) Placeholder) v') -> (quickSimpl (App k' (Name Unknown (bname i)))) -> | bind == (name "unsafeBind") -> = do i <- get -> put (i+1) -> return $ Let (bname i) Star -- type irrelevant -> v (quickSimpl (App k (Name Unknown (bname i)))) -> deIO' (App (App (Name _ ret) _) a) -- (without forcing) -> | (not erase) && ret == ioretNamei = deIO' a -> deIO' (App (Name _ ret) a) -- (with forcing) -> | erase && ret == ioretNamei = deIO' a -> deIO' (App (App (Name _ upio) _) a) -> | upio == (name "unsafePerformIO") = deIO' a -> deIO' (App (App (Name _ iolift) _) io) -> | iolift == ioliftNamei -- Just skip this -> = deIO' io -> deIO' (App (App (App (Name _ iodo) _) c) k) -- (without forcing) -> | (not erase) && iodo == iodoNamei -> = do k' <- deIO' k -> c' <- deIO' c -> i <- get -> put (i+1) -> return $ Let (bname i) Star -> (App (App (Name Unknown (name "__effect")) Placeholder) c') -> (quickSimpl (App k' (Name Unknown (bname i)))) -> deIO' (App (App (Name _ iodo) c) k) -- (with forcing) -> | erase && iodo == iodoNamei -> = do k' <- deIO' k -> c' <- deIO' c -> i <- get -> put (i+1) -> return $ Let (bname i) Star -> (App (App (Name Unknown (name "__effect")) Placeholder) c') -> (quickSimpl (App k' (Name Unknown (bname i)))) -> deIO' (App f a) = do f' <- deIO' f -> a' <- deIO' a -> return (App f' a') -> deIO' (Lambda n ty sc) = do sc' <- deIO' sc -> return (Lambda n ty sc') -> deIO' (Let n ty v sc) = do v' <- deIO' v -> sc' <- deIO' sc -> return (Let n ty v' sc') -> deIO' x = return x - -Simplify the common case in bind/IODo - -> quickSimpl (App (Lambda x ty sc) val) -> = subst x val sc -> quickSimpl x = x diff --git a/Idris/Parser.y b/Idris/Parser.y deleted file mode 100644 --- a/Idris/Parser.y +++ /dev/null @@ -1,833 +0,0 @@ -{ -- -*-Haskell-*- -{-# OPTIONS_GHC -fglasgow-exts #-} - -module Idris.Parser where - -import Data.Char -import Ivor.TT -import System.IO.Unsafe -import List -import Control.Monad - -import Idris.AbsSyntax -import Idris.Lexer -import Idris.Lib - -import Debug.Trace - -} - -%name mkparse Program -%name mkparseTerm Term -%name mkparseTactic Tactic - -%tokentype { Token } -%monad { P } { thenP } { returnP } -%lexer { lexer } { TokenEOF } - --- %expect 0 - -%token - name { TokenName $$ } - userinfix { TokenInfixName $$ } - brackname { TokenBrackName $$ } - string { TokenString $$ } - int { TokenInt $$ } - float { TokenFloat $$ } - char { TokenChar $$ } - bool { TokenBool $$ } - metavar { TokenMetavar $$ } - ':' { TokenColon } - ';' { TokenSemi } - '|' { TokenBar } - stars { TokenStars } - '\\' { TokenLambda } - hashbrack { TokenHashOB } - '(' { TokenOB } - ')' { TokenCB } - '{' { TokenOCB } - '}' { TokenCCB } - '[' { TokenOSB } - ']' { TokenCSB } - oid { TokenOId } - cid { TokenCId } - lpair { TokenLPair } - rpair { TokenRPair } - exists { TokenExists } - '~' { TokenTilde } - '+' { TokenPlus } - '-' { TokenMinus } - '*' { TokenTimes } - '/' { TokenDivide } - '=' { TokenEquals } - mightbe { TokenMightEqual } - '<' { TokenLT } - '>' { TokenGT } - ellipsis { TokenEllipsis } - '_' { TokenUnderscore } - ',' { TokenComma } - '&' { TokenTuple } - '!' { TokenBang } - concat { TokenConcat } --- eq { TokenEQ } - ge { TokenGE } - le { TokenLE } - or { TokenOr } - and { TokenAnd } - arrow { TokenArrow } - fatarrow { TokenFatArrow } - transarrow { TokenTransArrow } - leftarrow { TokenLeftArrow } - inttype { TokenIntType } - chartype { TokenCharType } - floattype { TokenFloatType } - stringtype { TokenStringType } - handletype { TokenHandleType } - ptrtype { TokenPtrType } - locktype { TokenLockType } - type { TokenType } - ltype { TokenLType } - lazybracket { TokenLazyBracket } - data { TokenDataType } - codata { TokenCoDataType } - infix { TokenInfix } - infixl { TokenInfixL } - infixr { TokenInfixR } - using { TokenUsing } - idiom { TokenIdiom } - params { TokenParams } - namespace { TokenNamespace } - public { TokenPublic } - private { TokenPrivate } - abstract { TokenAbstract } - noelim { TokenNoElim } - collapsible { TokenCollapsible } - where { TokenWhere } - with { TokenWith } - partial { TokenPartial } - syntax { TokenSyntax } - hide { TokenHide } - lazy { TokenLazy } - static { TokenStatic } - refl { TokenRefl } - empty { TokenEmptyType } - unit { TokenUnitType } - include { TokenInclude } - export { TokenExport } - inline { TokenInline } - do { TokenDo } - return { TokenReturn } - if { TokenIf } - then { TokenThen } - else { TokenElse } - let { TokenLet } - in { TokenIn } - proof { TokenProof } - try { TokenTryProof } - intro { TokenIntro } - refine { TokenRefine } - generalise { TokenGeneralise } - reflp { TokenReflP } - rewrite { TokenRewrite } - rewriteall { TokenRewriteAll } - compute { TokenCompute } - unfold { TokenUnfold } - undo { TokenUndo } - induction { TokenInduction } - fill { TokenFill } - trivial { TokenTrivial } - simplesearch { TokenSimpleSearch } - mktac { TokenMkTac } - believe { TokenBelieve } - use { TokenUse } - decide { TokenDecide } - abandon { TokenAbandon } - proofterm { TokenProofTerm } - qed { TokenQED } - latex { TokenLaTeX } - nocg { TokenNoCG } - eval { TokenEval } - spec { TokenSpec } - freeze { TokenFreeze } - thaw { TokenThaw } - transform { TokenTransform } - cinclude { TokenCInclude } - clib { TokenCLib } - -%nonassoc LAM -%nonassoc let in -%nonassoc '!' '@' -%nonassoc NEG -%left or -%left and '&' -%left '=' -- eq -%left userinfix -%left '<' le '>' ge -%left '+' '-' -%left '*' '/' -%left concat -%left '\\' -%right arrow -%left '(' '{' lazybracket '[' -%nonassoc '.' -%right IMP -%nonassoc CONST --- All the things I don't want to cause a reduction inside a lam... -%nonassoc name inttype chartype floattype stringtype int char string float bool refl do type ltype - empty unit '_' ptrtype handletype locktype metavar NONE brackname lazy - oid '~' lpair PAIR return transarrow exists proof -%left APP -%nonassoc if then else - -%% - -Program :: { [ParseDecl] } -Program: { [] } - | Declaration Program { $1:$2 } - | Fixity Program { map RealDecl $1 ++ $2 } - | include string ';' Program { RealDecl (PInclude $2) : $4 } - -{- -{% - let rest = $4 in - let pt = unsafePerformIO (readLib defaultLibPath $2) in - case (mkparse pt $2 1 []) of - Success x -> returnP (x ++ rest) - Failure err file ln -> failP err - } --} - -Declaration :: { ParseDecl } -Declaration: Function { $1 } - | Datatype { RealDecl (DataDecl $1) } - | Latex { RealDecl $1 } - | freeze name File Line ';' { RealDecl (Freeze $3 $4 [] $2) } - | Using '{' Program '}' { PUsing $1 $3 } - | DoUsing '{' Program '}' { PDoUsing $1 $3 } - | Idiom '{' Program '}' { PIdiom $1 $3 } - | Params '{' Program '}' { PParams $1 $3 } - | Namespace '{' Program '}' { PNamespace $1 $3 } - | Transform { RealDecl $1 } - | syntax Name NamesS '=' Term ';' { RealDecl (SynDef $2 $3 $5) } - | hide Name File Line ';' - { RealDecl (SynDef $2 [] (RVar $3 $4 (mkhidden $2) Unknown)) } - | cinclude string { RealDecl (CInclude $2) } - | clib string { RealDecl (CLib $2) } - -Transform :: { Decl } -Transform : transform Term fatarrow Term ';' { Transform $2 $4 } - -Function :: { ParseDecl } -Function : Name ':' Type ';' Flags File Line { FunType $1 $3 (nub $5) $6 $7 } - | Name ProofScript ';' { ProofScript $1 $2 } --- | DefTerm '=' Term Flags ';' { FunClause (mkDef $1) [] $3 $4 } - | DefTerm WithTerms WithP Term '{' Functions '}' File Line - { WithClause (mkDef $8 $9 $1) $2 $3 $4 $6 } - | DefTerm WithTerms mightbe Term ';' '[' Name ']' File Line - { FunClauseP (mkDef $9 $10 $1) $2 $4 $7 } - | DefTerm WithTerms '=' Term ';' Flags File Line - { FunClause (mkDef $7 $8 $1) $2 $4 (nub $6) } - | '|' WithTerm '=' Term ';' { FunClause RPlaceholder [$2] $4 [] } - | '|' WithTerm mightbe Term ';' '[' Name ']' - { FunClauseP RPlaceholder [$2] $4 $7 } - | '|' WithTerm WithP Term '{' Functions '}' - { WithClause RPlaceholder [$2] $3 $4 $6 } - -Visibility :: { CGFlag } -Visibility : public { Vis Public } - | private { Vis Private } - | abstract { Vis Abstract } - | { Vis Public } - -WithP :: { Bool } -WithP : with { False } - | with proof { True } - -WithTerms :: { [RawTerm] } -WithTerms : '|' WithTerm WithTerms { $2:$3 } - | { [] } - -WithTerm :: { RawTerm } -WithTerm : SimpleAppTerm { $1 } - | SigmaTerm { $1 } - | '(' Term ')' { $2 } - | '(' TermList ')' File Line { pairDesugar $4 $5 (RVar $4 $5 (UN "mkPair") Unknown) $2 } - -Functions :: { [ParseDecl] } -Functions : Function Functions { $1:$2 } - | Function { [$1] } - -Flags :: { [CGFlag] } -Flags : '[' FlagList ']' { $2 } - | { [] } - -FlagList :: { [CGFlag] } -FlagList : { [] } - | Flag FlagList { $1 ++ $2 } - -Flag :: { [CGFlag] } -Flag : nocg { [NoCG] } - | eval { [CGEval, Inline] } - | spec '(' NameInts ')' { [CGSpec $3] } - | spec { [CGSpec []] } - | inline { [Inline] } - | export string { [CExport $2] } - --- | Nameproof Script { ProofScript $2 } - --- | proof '{' Tactics '}' { error "Foo" } - --- Tactics :: { [(ITactic] } --- Tactics : - --- | Name '=' Term ';' { RealDecl (TermDef $1 $3) } - -Fixity :: { [Decl] } -Fixity : FixDec int UserInfixes ';' { map (\x -> Fixity x $1 $2) $3 } - -UserInfixes :: { [String] } -UserInfixes : UserInfix { [$1] } - | UserInfix ',' UserInfixes { $1:$3 } - --- some annoying special cases so we can have operators with other meanings. - -UserInfix :: { String } -UserInfix : userinfix { $1 } - | '-' { "-" } - | '<' { "<" } - | '>' { ">" } - -FixDec :: { Fixity } -FixDec : infixl { LeftAssoc } - | infixr { RightAssoc } - | infix { NonAssoc } - -Latex :: { Decl } -Latex : latex '{' LatexDefs '}' { LatexDefs $3 } - -LatexDefs :: { [(Id,String)] } -LatexDefs : Name '=' string { [($1,$3)] } - | Name '=' string ',' LatexDefs { ($1,$3):$5 } - -DefTerm :: { (Id, [(RawTerm, Maybe Id)]) } -DefTerm : Name ArgTerms { ($1, $2) } - -ArgTerms :: { [(RawTerm,Maybe Id)] } -ArgTerms : { [] } - | NoAppTerm ArgTerms { ($1,Nothing):$2 } - | brackname '}' ArgTerms File Line { (RVar $4 $5 $1 Unknown, Just $1):$3 } - | brackname '=' Term '}' ArgTerms { ($3, Just $1):$5 } - -Datatype :: { Datatype } -Datatype : Data DataOpts Name DefinedData File Line - { mkDatatype $1 $5 $6 $3 $4 $2 } - -Data :: { Bool } -Data : data { False } - | codata { True } - -DefinedData :: { Either RawTerm ((RawTerm, [(Id, RawTerm)]), [ConParse]) } -DefinedData : DType Constructors ';' { Right ($1,$2) } - | ':' Type ';' { Left $2 } - | ';' File Line { Left (RConst $2 $3 TYPE) } - --- Currently just whether to generate an elim rule, this'll need to be --- a list of options if we ever expand this. - -DataOpts :: { [TyOpt] } -DataOpts : { [] } - | '[' DataOptList ']' { $2 } - -DataOptList :: { [TyOpt] } -DataOptList : DataOpt { [$1] } - | DataOpt ',' DataOptList { $1:$3 } - -DataOpt :: { TyOpt } -DataOpt : noelim { NoElim } - | collapsible { Collapsible } - -Name :: { Id } -Name : name { $1 } - | '(' UserInfix ')' { useropFn $2 } - -SimpleAppTerm :: { RawTerm } -SimpleAppTerm : SimpleAppTerm File Line NoAppTerm %prec APP { RApp $2 $3 $1 $4 } - | SimpleAppTerm ImplicitTerm '}' File Line %prec APP - { RAppImp $4 $5 (fst $2) $1 (snd $2) } - | Name File Line { RVar $2 $3 $1 Unknown } - | Constant File Line { RConst $2 $3 $1 } - | '_' { RPlaceholder } - | empty File Line { RVar $2 $3 (UN "__Empty") TypeCon } - | unit File Line { RVar $2 $3 (UN "__Unit") TypeCon } - -Term :: { RawTerm } -Term : NoAppTerm { $1 } - | hashbrack Type ')' { $2 } - | Term File Line NoAppTerm %prec APP { RApp $2 $3 $1 $4 } - | Term ImplicitTerm '}' File Line %prec APP - { RAppImp $4 $5 (fst $2) $1 (snd $2) } - | lazy Term File Line { RApp $3 $4 (RApp $3 $4 (RVar $3 $4 (UN "__lazy") Free) RPlaceholder) $2 } - | '\\' Binds fatarrow Term %prec LAM - { doBind Lam $2 $4 } - | let LetBinds in Term - { doLetBind $2 $4 } - | InfixTerm { $1 } - | if Term then Term else Term File Line - { mkApp $7 $8 (RVar $7 $8 (UN "if_then_else") Free) [$2,$4,$6] } - -Binds :: { [(Id, RawTerm)] } -Binds : Name MaybeType { [($1,$2)] } - | Name MaybeType ',' Binds { ($1,$2):$4 } - -TypedBinds :: { [(Id, RawTerm)] } -TypedBinds : TypedBind ',' TypedBinds { $1 ++ $3 } - | TypedBind { $1 } - -TypedBind :: { [(Id, RawTerm)] } -TypedBind : Name ':' Type { map ( \x -> (x,$3)) [$1] } - -Names :: { [Id] } -Names : Name { [$1] } - | Name ',' Names { $1:$3 } - -NameInts :: { [(Id, Int)] } -NameInts : Name int { [($1,$2)] } - | Name { [($1, 0)] } - | Name ',' NameInts { ($1,0):$3 } - | Name int ',' NameInts { ($1,$2):$4 } - -BrackNames :: { [Id] } -BrackNames : brackname { [$1] } - | brackname ',' Names { $1:$3 } - -NamesS :: { [Id] } -NamesS : { [] } - | Name NamesS { $1:$2 } - -LetBinds :: { [(Id, RawTerm, RawTerm)] } -LetBinds : Name MaybeType '=' Term { [($1,$2,$4)] } - | Name MaybeType '=' Term ',' LetBinds { ($1,$2,$4):$6 } - -ImplicitTerm :: { (Id, RawTerm) } -ImplicitTerm : brackname File Line { ($1, RVar $2 $3 $1 Unknown) } - | brackname '=' Term { ($1, $3) } - -InfixTerm :: { RawTerm } -InfixTerm : '-' Term File Line %prec NEG { RInfix $3 $4 Minus (RConst $3 $4 (Num 0)) $2 } --- | Term '+' Term File Line { RInfix $4 $5 Plus $1 $3 } - | Term '-' Term File Line %prec userinfix { RUserInfix $4 $5 False "-" $1 $3 } --- | Term '*' Term File Line { RInfix $4 $5 Times $1 $3 } --- | Term '/' Term File Line { RInfix $4 $5 Divide $1 $3 } --- | Term and Term File Line { RInfix $4 $5 OpAnd $1 $3 } - | Term '&' Term File Line { mkApp $4 $5 (RVar $4 $5 (UN "Pair") TypeCon) [$1, $3] } --- | Term or Term File Line { RInfix $4 $5 OpOr $1 $3 } --- | Term concat Term File Line { RInfix $4 $5 Concat $1 $3 } --- | Term eq Term File Line { RInfix $4 $5 OpEq $1 $3 } - | Term '<' Term File Line { RUserInfix $4 $5 False "<" $1 $3 } --- | Term le Term File Line { RInfix $4 $5 OpLEq $1 $3 } - | Term '>' Term File Line { RUserInfix $4 $5 False ">" $1 $3 } --- | Term ge Term File Line { RInfix $4 $5 OpGEq $1 $3 } - | Term arrow Term File Line { RBind (MN "X" 0) (Pi Ex [] $1) $3 } - | UserInfixTerm { $1 } - | NoAppTerm '=' NoAppTerm File Line { RInfix $4 $5 JMEq $1 $3 } - -UserInfixTerm :: { RawTerm } -UserInfixTerm : Term userinfix Term File Line { RUserInfix $4 $5 False $2 $1 $3 } - -Section :: { RawTerm } -Section : '(' userinfix Term File Line ')' - { RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix $4 $5 False $2 (RVar $4 $5 (MN "X" 0) Unknown) $3) } - | '(' Term userinfix File Line ')' - { RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix $4 $5 False $3 $2 (RVar $4 $5 (MN "X" 0) Unknown)) } - | '(' BuiltinOp Term File Line ')' - { RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix $4 $5 False $2 (RVar $4 $5 (MN "X" 0) Unknown) $3) } - | '(' Term BuiltinOp File Line ')' - { RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix $4 $5 False $3 $2 (RVar $4 $5 (MN "X" 0) Unknown)) } - | '(' Term '-' File Line ')' - { RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix $4 $5 False "-" $2 (RVar $4 $5 (MN "X" 0) Unknown)) } - --- Special cases for -> - - | '(' Term arrow File Line ')' - { RBind (MN "X" 0) (Lam RPlaceholder) - (RBind (MN "X" 1) (Pi Ex [] $2) (RVar $4 $5 (MN "X" 0) Unknown)) } - | '(' arrow Term File Line ')' - { RBind (MN "X" 0) (Lam RPlaceholder) - (RBind (MN "X" 1) (Pi Ex [] (RVar $4 $5 (MN "X" 0) Unknown)) $3) } - | '(' arrow File Line ')' - { RBind (MN "X" 0) (Lam RPlaceholder) - (RBind (MN "X" 1) (Lam RPlaceholder) - (RBind (MN "X" 2) (Pi Ex [] (RVar $3 $4 (MN "X" 0) Unknown)) - (RVar $3 $4 (MN "X" 1) Unknown))) } - - -- Special cases for pairing - - | '(' ',' File Line ')' - { RBind (MN "X" 0) (Lam RPlaceholder) - (RBind (MN "X" 1) (Lam RPlaceholder) - (pairDesugar $3 $4 (RVar $3 $4 (UN "mkPair") DataCon) - [RVar $3 $4 (MN "X" 0) Unknown, - RVar $3 $4 (MN "X" 1) Unknown])) } - | '(' Term ',' File Line ')' - { RBind (MN "X" 0) (Lam RPlaceholder) - (pairDesugar $4 $5 (RVar $4 $5 (UN "mkPair") DataCon) - [$2, - RVar $4 $5 (MN "X" 0) Unknown]) } - | '(' ',' Term File Line ')' - { RBind (MN "X" 0) (Lam RPlaceholder) - (pairDesugar $4 $5 (RVar $4 $5 (UN "mkPair") DataCon) - [RVar $4 $5 (MN "X" 0) Unknown, $3]) } - - -BuiltinOp :: { String } -BuiltinOp : '<' { "<" } - | '>' { ">" } - -MaybeType :: { RawTerm } -MaybeType : { RPlaceholder} - | ':' TypeTerm { $2 } - -MaybeAType :: { RawTerm } -MaybeAType : { RPlaceholder} - | ':' TypeTerm { $2 } - --- Term representing a type may begin with implicit argument list - -Type :: { RawTerm } -Type : BrackNames MaybeAType '}' arrow Type - { doBind (Pi Im []) (map (\x -> (x, $2)) $1) $5 } - | TypeTerm { $1 } - -TypeTerm :: { RawTerm } -TypeTerm : TypeTerm arrow TypeTerm { RBind (MN "X" 0) (Pi Ex [] $1) $3 } - | '(' TypedBinds ')' ArgOpts arrow TypeTerm - { doBind (Pi Ex $4) $2 $6 } - | lazybracket TypedBinds ')' arrow TypeTerm - { doBind (Pi Ex [Lazy]) $2 $5 } - | '(' TypeTerm ')' { bracket $2 } - | '(' TypeTerm '=' TypeTerm File Line ')' { RInfix $5 $6 JMEq $2 $4 } - | SimpleAppTerm { $1 } - | hashbrack Term ')' { $2 } - | TypeTerm userinfix TypeTerm File Line { RUserInfix $4 $5 False $2 $1 $3 } - | TypeTerm '-' TypeTerm File Line { RUserInfix $4 $5 False "-" $1 $3 } - | '(' TypeList ')' File Line { pairDesugar $4 $5 (RVar $4 $5 (UN "Pair") TypeCon) $2 } - | SigmaType { $1 } - -ArgOpt :: { ArgOpt } -ArgOpt : lazy { Lazy } - | static { Static } - -ArgOpts :: { [ArgOpt] } -ArgOpts : '[' ArgOptList ']' { $2 } - | { [] } - -ArgOptList :: { [ArgOpt] } -ArgOptList : ArgOpt ',' ArgOptList { $1:$3 } - | ArgOpt { [$1] } - -SigmaType :: { RawTerm } -SigmaType : '(' Name MaybeType stars TypeTerm ')' File Line - { sigDesugar $7 $8 ($2, $3) $5 } --- | exists Name MaybeType fatarrow SimpleAppTerm File Line --- { sigDesugar $6 $7 ($2, $3) $5 } - -TypeList :: { [RawTerm] } - : TypeTerm '&' TypeTerm { $1:$3:[] } - | TypeTerm '&' TypeList { $1:$3 } - -NoAppTerm :: { RawTerm } -NoAppTerm : Name File Line { RVar $2 $3 $1 Unknown } - | return File Line { RReturn $2 $3 } - | '(' Term ')' { bracket $2 } - | '~' NoAppTerm { RPure $2 } - | metavar { RMetavar $1 } - | '[' proof Tactics ']' { RMetavarPrf (UN "") $3 False } - | '[' try Tactics ']' { RMetavarPrf (UN "") $3 True } - | '!' Name File Line { RExpVar $3 $4 $2 } --- | '{' TypedBind '}' arrow NoAppTerm --- { doBind (Pi Im) $2 $5 } - | Constant File Line { RConst $2 $3 $1 } - | refl { RRefl } - | empty File Line { RVar $2 $3 (UN "__Empty") TypeCon } - | unit File Line { RVar $2 $3 (UN "__Unit") TypeCon } - | '_' { RPlaceholder } - | DoBlock { RDo $1 } - | oid Term cid { RIdiom $2 } - | '(' TermList ')' File Line { pairDesugar $4 $5 (RVar $4 $5 (UN "mkPair") DataCon) $2 } --- | '[' TermList ']' File Line { pairDesugar $4 $5 (RVar $4 $5 (UN "Exists")) $2 } --- | '(' TypeList ')' File Line { pairDesugar $4 $5 (RVar $4 $5 (UN "Pair")) $2 } - | SigmaType { $1 } - | Section { $1 } - | SigmaTerm { $1 } - | '[' File Line TermListZ ']' { mkConsList $2 $3 $4 } - -SigmaTerm :: { RawTerm } -SigmaTerm : lpair Term ',' Term rpair File Line %prec PAIR - { RApp $6 $7 (RApp $6 $7 (RVar $6 $7 (UN "Exists") DataCon) $2) $4 } - | lpair Term rpair File Line %prec PAIR - { RApp $4 $5 (RApp $4 $5 (RVar $4 $5 (UN "Exists") DataCon) RPlaceholder) $2 } - -TermList :: { [RawTerm] } - : Term ',' Term { $1:$3:[] } - | Term ',' TermList { $1:$3 } - -TermListZ :: { [RawTerm] } - : { [] } - | Term { [$1] } - | Term ',' TermListZ { $1:$3 } - - -DoBlock :: { [Do] } -DoBlock : do '{' DoBindings '}' { $3 } --- Next rule is a TMP HACK! So that we can open brackets then have a name immediately. - | do brackname MaybeType leftarrow Term File Line ';' DoBindings '}' - { DoBinding $6 $7 $2 $3 $5 : $9 } - -DoBindings :: { [Do] } -DoBindings : DoBind DoBindings { $1:$2} - | DoBind { [$1] } - -DoBind :: { Do } -DoBind : Name MaybeType leftarrow Term File Line ';' { DoBinding $5 $6 $1 $2 $4 } - | let Name MaybeType '=' Term File Line ';' { DoLet $6 $7 $2 $3 $5 } - | Term File Line ';' { DoExp $2 $3 $1 } - -Constant :: { Constant } -Constant : type { TYPE } - | ltype { LTYPE } - | stringtype { StringType } - | inttype { IntType } - | chartype { CharType } - | floattype { FloatType } - | ptrtype { PtrType } - | handletype { Builtin "Handle" } - | locktype { Builtin "Lock" } - | int { Num $1 } - | char { Ch $1 } - | string { Str $1 } - | bool { Bo $1 } - | float { Fl $1 } - --- Whitespace separated term sequences; must be NoAppTerms since obviously --- application is space separated... - -Terms :: { [RawTerm] } -Terms : { [] } - | NoAppTerm Terms { $1:$2 } - -DType :: { (RawTerm, [(Id, RawTerm)]) } -DType : ':' Type Using where { ($2, $3) } - | '=' File Line { (RConst $2 $3 TYPE, []) } - | VarList '=' File Line { (mkTyParams $3 $4 $1, []) } - -Using :: { [(Id, RawTerm)] } - : { [] } - | using '(' UseList ')' { $3 } - -DoUsing ::{ (Id,Id) } - : do using '(' Name ',' Name ')' { ($4,$6) } - -Idiom ::{ (Id,Id) } - : idiom '(' Name ',' Name ')' { ($3,$5) } - - -Params :: { [(Id, RawTerm)] } - : params '(' UseList ')' { $3 } - -Namespace :: { Id } - : namespace Name { $2 } - -UseList :: { [(Id, RawTerm)] } - : Name ':' Type { [($1, $3)] } - | Name ':' Type ',' UseList { ($1,$3):$5 } - -VarList :: { [Id] } -VarList : Name { [$1] } - | Name VarList { $1:$2 } - -Where : where { $1 } - | '=' { $1 } - -Constructors :: { [ConParse] } -Constructors : { [] } -- None - | Constructor { [$1] } - | Constructor '|' Constructors { $1:$3 } - -Constructor :: { ConParse } -Constructor : Name CType { Full $1 $2 } - | Name Terms { Simple $1 $2 } --- | Name { Simple $1 [] } - -CType :: { RawTerm } -CType : ':' Type { $2 } - -Tactic :: { ITactic } -Tactic : intro Names { Intro $2 } - | intro { Intro [] } - | refine Name { Refine $2 } - | exists Term { Exists $2 } - | generalise Term { Generalise $2 } - | reflp { ReflP } - | rewrite Term { Rewrite False False $2 } - | rewrite leftarrow Term { Rewrite False True $3 } - | rewriteall Term { Rewrite True False $2 } - | rewriteall leftarrow Term { Rewrite True True $3 } - | compute { Compute } - | unfold Name { Unfold $2 } - | undo { Undo } - | induction Term { Induction $2 } - | fill Term { Fill $2 } - | trivial { Trivial } - | simplesearch { SimpleSearch } - | mktac Term { RunTactic $2 } - | believe Term { Believe $2 } - | use Term { Use $2 } - | decide Term { Decide $2 } - | abandon { Abandon } - | proofterm { ProofTerm } - | qed { Qed } - -ProofScript :: { [ITactic] } -ProofScript : proof '{' Tactics '}' { $3 } - -Tactics :: { [ITactic] } -Tactics : Tactic ';' { [$1] } - | Tactic { [$1] } - | Tactic ';' Tactics { $1:$3 } - -TacticList :: { [ITactic] } -TacticList : Tactic { [$1] } - | Tactic ',' Tactics { $1:$3 } - -Line :: { LineNumber } - : {- empty -} {% getLineNo } - -File :: { String } - : {- empty -} %prec NONE {% getFileName } - -Ops :: { Fixities } - : {- empty -} %prec NONE {% getOps } - -{ - -data ConParse = Full Id RawTerm - | Simple Id [RawTerm] - -parse :: String -> FilePath -> Result [Decl] -parse s fn = do ds <- mkparse s fn 1 [] - collectDecls ds - -processImports :: [Opt] -> [FilePath] -> Result [Decl] -> - IO ([Decl], [FilePath]) -processImports opts imped (Success ds) = pi imped [] ds - where pi imps decls ((PInclude fp):xs) - | fp `elem` imps = pi imps decls xs - | otherwise = do - f <- readLibFile defaultLibPath fp - when (Verbose `elem` opts) $ putStrLn ("Reading " ++ fp) - case parse f fp of - Success t -> pi (fp:imps) decls (t++xs) - Failure e f l -> - fail $ f ++ ":" ++ show l ++ ":" ++ e - pi imps decls ((Using t ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[Using t ds']) xs - pi imps decls ((Params t ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[Params t ds']) xs - pi imps decls ((DoUsing b r ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[DoUsing b r ds']) xs - pi imps decls ((Idiom b r ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[Idiom b r ds']) xs - pi imps decls ((Namespace n ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[Namespace n ds']) xs - pi imps decls (x:xs) = pi imps (decls++[x]) xs - pi imps decls [] = return (decls, imps) - -processImports _ imped (Failure e f l) - = fail $ show f ++ ":" ++ show l ++ ":" ++ show e - - -parseTerm :: String -> Result RawTerm -parseTerm s = mkparseTerm s "(input)" 0 [] - -parseTactic :: String -> Result ITactic -parseTactic s = mkparseTactic s "(tactic)" 0 [] - --- Make a constructor type, and make arguments lazy if it's codata - -mkCon :: Bool -> RawTerm -> ConParse -> (Id,RawTerm) -mkCon co _ (Full n t) = (n,if co then lazify t else t) -mkCon co ty (Simple n args) = (n, mkConTy args ty) - where mkConTy [] ty = ty - mkConTy (a:as) ty = let opts = if co then [Lazy] else [] in - RBind (MN "X" 0) (Pi Ex opts a) (mkConTy as ty) - --- Make sure all arguments are lazy - -lazify :: RawTerm -> RawTerm -lazify (RBind n (Pi p opts a) sc) - = RBind n (Pi p (nub (Lazy:opts)) a) (lazify sc) -lazify t = t - -mkDef file line (n, tms) = mkImpApp (RVar file line n Unknown) tms - where mkImpApp f [] = f - mkImpApp f ((tm,Just n):ts) = mkImpApp (RAppImp file line n f tm) ts - mkImpApp f ((tm, Nothing):ts) = mkImpApp (RApp file line f tm) ts - -doBind :: (RawTerm -> RBinder) -> [(Id,RawTerm)] -> RawTerm -> RawTerm -doBind b [] t = t -doBind b ((x,ty):ts) tm = RBind x (b ty) (doBind b ts tm) - -doLetBind :: [(Id,RawTerm,RawTerm)] -> RawTerm -> RawTerm -doLetBind [] t = t -doLetBind ((x,ty,val):ts) tm = RBind x (RLet val ty) (doLetBind ts tm) - -mkTyApp :: String -> Int -> Id -> RawTerm -> RawTerm -mkTyApp file line n ty = mkApp file line (RVar file line n Unknown) (getTyArgs ty) - where getTyArgs (RBind n _ t) = (RVar file line n Unknown):(getTyArgs t) - getTyArgs x = [] - -mkTyParams :: String -> Int -> [Id] -> RawTerm -mkTyParams f l [] = RConst f l TYPE -mkTyParams f l (x:xs) = RBind x (Pi Ex [] (RConst f l TYPE)) (mkTyParams f l xs) - -mkDatatype :: Bool -> String -> Int -> - Id -> Either RawTerm ((RawTerm, [(Id, RawTerm)]), [ConParse]) -> - [TyOpt] -> Datatype -mkDatatype co file line n (Right ((t, using), cons)) opts - = let opts' = if co then nub (Codata:opts) else opts in - Datatype n t (map (mkCon co (mkTyApp file line n t)) cons) using opts' file line -mkDatatype co file line n (Left t) opts - = Latatype n t file line - -bracket (RUserInfix f l _ op x y) = RUserInfix f l True op x y -bracket x = x - -pairDesugar :: String -> Int -> RawTerm -> [RawTerm] -> RawTerm -pairDesugar file line pair [x,y] = mkApp file line pair [x,y] -pairDesugar file line pair (x:y:xs) - = pairDesugar file line pair ((mkApp file line pair [x,y]):xs) - -sigDesugar :: String -> Int -> (Id, RawTerm) -> RawTerm -> RawTerm -sigDesugar file line (n, tm) sc - = mkApp file line (RVar file line (UN "Sigma") TypeCon) [tm, lam] - where lam = RBind n (Lam tm) sc - -mkConsList :: String -> Int -> [RawTerm] -> RawTerm -mkConsList f l [] = RVar f l (UN "Nil") Unknown -mkConsList f l (x:xs) = RApp f l (RApp f l (RVar f l (UN "Cons") Unknown) x) - (mkConsList f l xs) - -mkhidden (UN n) = MN (n++" is hidden") 0 - -} - diff --git a/Idris/PartialEval.lhs b/Idris/PartialEval.lhs deleted file mode 100644 --- a/Idris/PartialEval.lhs +++ /dev/null @@ -1,310 +0,0 @@ -Various bits and pieces to help do partial evaluation better. - -This module doesn't do PE itself - rather, it sets up the %transform, %spec -and %freeze annotations. - -> module Idris.PartialEval(partialeval, addPEdefs, staticDecls, -> getNewDefs) where - -> import Idris.AbsSyntax -> import Ivor.TT as TT - -> import Maybe -> import List -> import Control.Monad.State -> import Debug.Trace - -> type NewTrans = [(ViewTerm, ViewTerm)] -> type NewFreeze = [Name] -> type NewDefs = [(Name, ViewTerm, Patterns, NewFreeze, (ViewTerm, ViewTerm))] - -> type StaticState = (NewDefs, StaticUsed, NewTrans, NewFreeze, Int) - -For everything in the context, look for applications of PEable functions, -with 'findStatic' below. -For each one, add a new definition, %spec it, %freeze it and add a -%transform rule that applies the new definition backwards. - -For a definition d which uses PEable functions, add the new definitions -to the new context *before* adding d, followed by the %transform and %freeze -for each new definition, followed by d. - - addPEdefs :: Statics -> IdrisState -> Ctxt IvorFun -> Ctxt IvorFun - addPEdefs sts ist raw = addpes newCtxt [] (ctxtAlist raw) - where addpes acc stu [] = acc - addpes acc stu ((n,i):is) = - let (i', defs, stu', _, _) = getPEdefs n sts ist raw stu i in - addpes (addEntry acc [] n i') stu' is - -> getPEdefs :: Id -> Statics -> IdrisState -> -> Ctxt IvorFun -> StaticUsed -> IvorFun -> -> (IvorFun, NewDefs, StaticUsed, NewTrans, NewFreeze) -> getPEdefs n sts ist raw stu i = -> case ivorDef i of -> Just d -> let (def', (nds, stused, ts, fs, _)) = runState (getPEdef n sts ist raw stu d) ([], stu, [], [], 0) in -> (i { ivorDef = Just def' }, nds, stused, ts, fs) -> Nothing -> (i, [], stu, [], []) - -> getNewDefs :: Id -> Statics -> IdrisState -> -> Ctxt IvorFun -> StaticUsed -> IvorDef -> -> (IvorDef, NewDefs, StaticUsed, NewTrans, NewFreeze) -> getNewDefs n sts ist raw stu d = -> let (d', (sts', stu', ts, fs, _)) = runState (getPEdef n sts ist raw stu d) ([],stu,[],[],0) in -> (d', sts', stu', ts, fs) - -> getPEdef :: Id -> Statics -> IdrisState -> Ctxt IvorFun -> -> StaticUsed -> IvorDef -> -> State StaticState IvorDef -> getPEdef n sts ist raw stu (PattDef (Patterns ps)) = -> do ps' <- mapM pepat ps -> return (PattDef (Patterns ps')) -> where -> pepat (PClause args bs ret) -> = do ret' <- findStatic n sts ist raw ret -> return (PClause args bs ret') -> pepat (PWithClause p args sc (Patterns ps)) -> = do sc' <- findStatic n sts ist raw sc -> ps' <- mapM pepat ps -> return (PWithClause p args sc' (Patterns ps')) -> getPEdef n sts ist raw stu (SimpleDef p) = -> do p' <- findStatic n sts ist raw p -> return (SimpleDef p') -> getPEdef _ _ _ _ _ x = return x - - -Given a list of functions with static arguments, and a term... -Look for applications of that function in the term. - -Replace them with a partially evaluated version (look in StaticsUsed first -to see if it's already been done.) - -Return: the new term, the new definitions added, and an updated cached of PEed -functions. - -> findStatic :: Id -> Statics -> IdrisState -> Ctxt IvorFun -> ViewTerm -> -> State StaticState ViewTerm -> findStatic n sts ist raw vt = fs [] vt -> where -> fs stk (App f a) = do a' <- fs [] a -> fs (a':stk) f -> fs stk (Lambda n ty sc) = do sc' <- fs [] sc -> freturn (Lambda n ty sc') stk -> fs stk (Let n ty v sc) = do v' <- fs [] v -> sc' <- fs [] sc -> freturn (Let n ty v' sc') stk -> fs stk (Annotation a vt) = do vt' <- fs stk vt -> return (Annotation a vt') - -Don't bother with PE inside types - -> fs stk x = freturn x stk - -> freturn (Name _ f) args -> | Just (sts,arity,ty) <- lookup f sts -> = if length args == arity -> then papply sts f ty args -> else if length args > arity -> then do let (args', rest) = (take arity args, -> drop arity args) -> app <- papply sts f ty args' -> return (apply app rest) -> else return (apply (Name Unknown f) args) -> freturn f args = return (apply f args) - -Check the arguments in static position are indeed statically known. - -> papply sts f ty args -> | all (known args) sts = -- trace (show (f, args, ty)) $ -> do let knownArgs = mkArgs sts 0 args -> let ty' = newTy ty knownArgs -> addDef f ty' knownArgs -> return (apply (Name Unknown f) args) -> papply sts f ty args = return (apply (Name Unknown f) args) - -Pull out the arguments that are statically known - -> mkArgs sts _ [] = [] -> mkArgs sts i (a:args) | i `elem` sts = Right a : (mkArgs sts (i+1) args) -> | otherwise = Left a : mkArgs sts (i+1) args - -> newTy (Forall n ty sc) (Left _ : rest) -> = Forall n ty (newTy sc rest) -> newTy (Forall n ty sc) (Right val : rest) -> = newTy (subst n val sc) rest -> newTy (Annotation a x) rest = Annotation a (newTy x rest) -> newTy x _ = x - -> known args i = all nknown (namesTypesIn (args!!!(i,"known fail"))) -> nknown x@(_,Free) = True -> nknown x@(_,DataCon) = True -> nknown x@(_,TypeCon) = True -> nknown x = False - -> addDef f ty args = -> do (nds, used, ts, fs, name) <- get -> let defname = toIvorName $ MN ("PE"++show n) name -> let sargs = mapMaybe getRight args -> let idx = (f, sargs) -> if (idx `elem` used) then return () else -> do -> let dargs = getDargs args nameSupply -> let rhs = reImplicit ist raw $ -> apply (Name Unknown f) (mkAppArgs args sargs dargs) -> let dargs' = map (dused (namesIn rhs)) dargs -> let used' = idx:used -> let transFrom = mktrans (getMVs args dargs') rhs -> let transTo = mktrans (getMVs args dargs') (apply (Name Unknown defname) dargs') -> let trans = (transFrom, transTo) -> let freeze = getFrozen transFrom -> let newdef = (defname, ty, Patterns [PClause dargs' [] rhs], freeze, trans) -> let nds' = newdef:nds -> put (nds', used', trans:ts, freeze ++ fs, name+1) - -> nameSupply = map (toIvorName.(MN "parg")) [0..] -> dused xs (Name _ n) | not (n `elem` xs) = Placeholder -> dused xs x = x - -> -- getDargs ((Left n@(Name _ _)):xs) ns = n : getDargs xs ns -> getDargs ((Left _):xs) (n:ns) = (Name Unknown n) : getDargs xs ns -> getDargs (_:xs) ns = getDargs xs ns -> getDargs [] _ = [] - -> getRight (Right x) = Just x -> getRight _ = Nothing - -Make a list of arguments for the specialisable application - -> mkAppArgs [] _ _ = [] -> mkAppArgs (Left _:xs) ss (d:ds) = d:(mkAppArgs xs ss ds) -> mkAppArgs (Right v:xs) (s:ss) ds = s:(mkAppArgs xs ss ds) -> mkAppArgs _ _ _ = [] - -Make the LHS and RHS of a transformation rule for the new definition - -> getMVs (Left _:xs) (Name _ n:ds) = n:(getMVs xs ds) -> getMVs (Left _:xs) (_:ds) = getMVs xs ds -> getMVs (Right v:xs) ds = getMVs xs ds -> getMVs _ _ = [] - -> mktrans (n:ns) tm = mktrans ns (subst n (Metavar n) tm) -> mktrans [] tm = tm - -> getFrozen tm = map fst (filter (\ (n, ty) -> ty == Free) (namesTypesIn tm)) - -Re-add _s for implicit arguments in PE definitions (because the type checker -will make a better job of working out what they should be than we will...) - -The terms will just be simple applications - -> reImplicit :: IdrisState -> Ctxt IvorFun -> ViewTerm -> ViewTerm -> reImplicit ist raw tm = reImp tm [] -> where reImp fn@(Name _ n) stk -> = case getName n of -> Right ifn -> let imps = implicitArgs ifn -> stk' = take imps (repeat Placeholder) -> ++ drop imps stk in -> apply fn stk' -> _ -> apply fn stk -> reImp (App f a) stk = reImp f ((reImp a []):stk) -> reImp (Annotation a t) stk = Annotation a (reImp t stk) -> reImp x stk = apply x stk - -> names = mkNameMap raw -> getName n = case lookup n names of -> Just x -> ctxtLookup raw [] x -> Nothing -> fail "No name" - - -Get a list of functions with static arguments, and their arities. - -> staticDecls :: Ctxt IvorFun -> Statics -> staticDecls ctx = mapMaybe getStatic (ctxtAlist ctx) -> where getStatic (n,i) -> = if null (staticArgs i) || fwdDef (rawDecl i) -> then Nothing -> else let statics = (map (+ (implicitArgs i)) (staticArgs i)) -> ar = arity (ivorDef i) -> extras = getExtras statics ar (ivorFType i) -> in Just (toIvorName n, -> (nub (extras ++ statics), ar, -> getType (ivorFType i))) - -> fwdDef (Fwd _ _ _) = True -> fwdDef _ = False -> getType (Just t) = t - -> arity (Just (PattDef ps)) = parity ps -> arity _ = 0 -> parity (Patterns []) = 0 -> parity (Patterns ((PClause xs _ _):_)) = length xs -> parity (Patterns ((PWithClause _ xs _ _):_)) = length xs - -Look for dependencies on the static arguments. Keep going until there are -no more. Add any dependencies on static arguments which are dependencies on -*no* dynamic arguments. - -> getExtras _ _ Nothing = [] -> getExtras ss ar (Just t) -> = let ds = [0..ar-1] \\ ss -> args = TT.getArgTypes t -> stypes = map (\x -> snd (args!!!(x,"extra 1"))) ss -> dtypes = map (\x -> snd (args!!!(x,"extra 2"))) ds -> stnames = concatMap namesIn stypes -> dnames = concatMap namesIn dtypes -> newss_in = nub (ss ++ (mapMaybe (\x -> lookupIdx 0 x args) stnames)) -> newds = mapMaybe (\x -> lookupIdx 0 x args) dnames -> newss = sort $ newss_in \\ newds in -> if (ss==newss) then ss else getExtras newss ar (Just t) -> lookupIdx i x ((n,v):xs) | n==x = Just i -> | otherwise = lookupIdx (i+1) x xs -> lookupIdx i x [] = Nothing - -> addPEdefs :: Ctxt IvorFun -> Context -> Statics -> UserOps -> NewDefs -> -> TTM (Context, UserOps, [Id]) -> addPEdefs raw ctxt sts uo nds = tryAdd ctxt uo [] nds -> where tryAdd ctxt uo frz [] = return (ctxt, uo, frz) -> tryAdd ctxt uo frz (d:ds) -> = case addPEdef ctxt uo d of -> Right (ctxt', uo', frz') -> -- trace ("WIN: " ++ show d) $ -> tryAdd ctxt' uo' (frz++frz') ds -> Left err -> trace ("FAIL: " ++ show d ++ "\n" ++ show err) $ -> tryAdd ctxt uo frz ds - -> addPEdef ctxt (UO fix trans frz syn) (n, ty, pdef, frz', trans') = -> do (ctxt, []) <- addPatternDef ctxt n ty pdef -> [Specialise (map (\x -> (x,1)) frz'), -> SpecStatic (map getst sts)] -> return (ctxt, UO fix (trans':trans) -> (map getName frz'++frz) syn, -> map getName frz') - -> getst (n, (args, arity, ty)) = (n,(args,arity)) -> names = mkNameMap raw -> getName n = case lookup n names of -> Just x -> x -> Nothing -> UN (show n) - -Go through the context, evaluating enough to work out what the transform -rules need to be. Return a new set of transform rules, and specialised versions -of PEable functions. - -Algorithm is: - -In a definition f, PE(f): - -For each static function I, with static positions s1...sn: -* If it appears in a pattern clause, - make a new function Ispec di = mkSpec (I di si) - repeat PE(Ispec) - add a transform I ?di si => Ispec ?di - if any si is a name, freeze it - -mkSpec(I di si): - -* Evaluate I di si. Any si which is a name, expand only once. - After the top level I, do not evaluate any static arguments of any I - - either they are all expanded, or we'll PE them separately. - -> partialeval :: Ctxt IvorFun -> Context -> Statics -> UserOps -> -> (Context, UserOps) -> partialeval raw ctxt sts uos = (ctxt, uos) diff --git a/Idris/Prover.lhs b/Idris/Prover.lhs deleted file mode 100644 --- a/Idris/Prover.lhs +++ /dev/null @@ -1,333 +0,0 @@ -> module Idris.Prover(doProof, runScript, doIvor, ioTac) where - -> import System.Console.Readline -> import Control.Monad hiding ((>=>)) -> import Data.Typeable - -> import Idris.AbsSyntax -> import Idris.Parser - -> import Ivor.Shell -> import Ivor.TT -> import Ivor.Construction - -> import Debug.Trace - -> ioTac :: TTM a -> IO a -> ioTac (Left a) = fail (show a) -> ioTac (Right v) = return v - -> doProof :: Ctxt IvorFun -> Context -> UserOps -> Id -> IO Context -> doProof raw ctxt uo nm = -> do ctxt' <- ioTac $ resume ctxt (toIvorName nm) -> ctxt' <- ioTac $ attack defaultGoal ctxt' -> putStrLn $ showCtxtState raw ctxt' -> (ctxt', script, ok) <- proofShell (show nm) raw uo [] ctxt' -> if ok then do -> return ctxt' -> else do putStrLn "Proof abandoned" -> return ctxt - -> runScript :: Ctxt IvorFun -> Context -> UserOps -> Id -> [ITactic] -> -> TTM Context -> runScript raw ctxt uo nm tacs = -> do ctxt <- resume ctxt (toIvorName nm) -> ctxt <- attack defaultGoal ctxt -> execScript raw ctxt uo tacs - -This function assumes that it can plough on knowing the proof is fine. -If it isn't, it'll break, but with an error. We probably ought to check -properly, if only for useful diagnostics. - -> execScript :: Ctxt IvorFun -> Context -> UserOps -> [ITactic] -> TTM Context -> execScript raw ctxt uo [] = return ctxt -> execScript raw ctxt uo (t:ts) -> = do (ctxt,_,_) <- applyTac raw ctxt uo [] t -> ctxt <- keepSolving defaultGoal ctxt -> ctxt <- if ((numUnsolved ctxt) > 0) -> then beta defaultGoal ctxt -> else return ctxt -> execScript raw ctxt uo ts - -> showScript :: String -> [String] -> IO () -> showScript nm sc -> = do putStrLn $ nm ++ " proof {" -> putStr $ concat (map (\line -> "\t" ++ line ++ ";\n") (sc++["%qed"])) -> putStrLn "};" - -Remember the proof script (that's the [String]) and output it, without the -undone bits, after a Qed - -> proofShell :: String -> Ctxt IvorFun -> UserOps -> [String] -> Context -> -> IO (Context, [String], Bool) -> proofShell nm raw uo script ctxt = do -> inp <- readline (nm ++ "> ") -> res <- case inp of -> Nothing -> return "" -> Just ":q" -> return "abandon" -> Just tac -> do addHistory tac -> return tac -> case parseTactic ("%"++res) of -> Failure err f l -> do putStrLn err -> proofShell nm raw uo script ctxt -> Success tac -> -> do let script' = script ++ ["%"++res] -> when (tac == Qed) $ -> showScript nm script -> case applyTac raw ctxt uo script' tac of -> Left err -> do print err -> proofShell nm raw uo script ctxt -> Right (ctxt, script, True) -> do -> ctxt <- ioTac $ keepSolving defaultGoal ctxt -> ctxt <- ioTac $ if ((numUnsolved ctxt) > 0) -> then beta defaultGoal ctxt -> else return ctxt -> if (proving ctxt) -> then do putStrLn $ showCtxtState raw ctxt -> proofShell nm raw uo script ctxt -> else return (ctxt, script, True) -> _ -> return (ctxt, script, False) - -> applyTac :: Ctxt IvorFun -> Context -> UserOps -> [String] -> ITactic -> -> TTM (Context, [String], Bool) -> applyTac raw ctxt uo script Abandon = return (ctxt, script, False) -> applyTac raw ctxt uo script Undo = do ctxt <- restore ctxt -> -- remove the undo and the command -> let script' = init (init script) -> return (ctxt, script', True) -> applyTac raw ctxt uo script tac = do ctxt <- at (save ctxt) tac -> return (ctxt, script, True) -> where -> at ctxt (Intro []) = intros defaultGoal ctxt -> at ctxt (Intro ns) = introsNames (map toIvorName ns) defaultGoal ctxt -> at ctxt (Refine n) = refine (Name Unknown (toIvorName n)) defaultGoal ctxt -> at ctxt (Generalise t) = generalise (ivor t) defaultGoal ctxt -> at ctxt (Exists t) = refine (App (App (App (Name Unknown (name "Exists")) -> Placeholder) Placeholder) -> (ivor t)) defaultGoal ctxt -> at ctxt ReflP = refine reflN defaultGoal ctxt -> at ctxt (Fill t) = fill (ivor t) defaultGoal ctxt -> at ctxt Trivial = (trivial >|> refine reflN) defaultGoal ctxt -> at ctxt SimpleSearch = (trivial >|> refine reflN >|> simplesearch raw uo) defaultGoal ctxt -> at ctxt (Believe t) = suspend_disbelief raw (ivor t) defaultGoal ctxt -> at ctxt (Use t) = prove_belief raw (ivor t) defaultGoal ctxt -> at ctxt (Decide t) = decide raw uo t defaultGoal ctxt -> at ctxt (Induction t) = induction (ivor t) defaultGoal ctxt -> at ctxt (Rewrite False f t) = rewrite (ivor t) f defaultGoal ctxt -> at ctxt (Rewrite True f t) = rewriteAll (ivor t) f defaultGoal ctxt -> at ctxt Compute = compute defaultGoal ctxt -> at ctxt (Unfold n) = unfold (toIvorName n) defaultGoal ctxt -> at ctxt (RunTactic tm) = runtac raw uo (ivor tm) defaultGoal ctxt -> at ctxt ProofTerm = do tm <- proofterm ctxt -> fail (showVT raw (view tm)) -> at ctxt Qed = qed ctxt - -> ivor t = makeIvorTerm noImplicit defDo uo (UN "__prf") raw t - -> eqN = Name Unknown $ name "Eq" -> replN = Name Unknown $ toIvorName (UN "__eq_repl") -> symN = Name Unknown $ toIvorName (UN "__eq_sym") -> reflN = Name Unknown $ name "refl" -> eqP x y = apply eqN [Placeholder,Placeholder,x,y] -> believe x y = apply (Name Unknown (toIvorName (UN "__Suspend_Disbelief"))) -> [Placeholder,x,y] - -> rewrite :: ViewTerm -> Bool -> Tactic -> rewrite = replace eqN replN symN - -Given a rewrite rule, find all places where it can be applied (in the given -direction), and apply it. Search for points where the goal matches the LHS -of the rule's type, and apply rewrite. - -> rewriteAll :: ViewTerm -> Bool -> Tactic -> rewriteAll (Name _ n) dir goal ctxt -> = do tyin <- getType ctxt n -> let ty = view tyin -> rule <- getRule dir (getReturnType ty) -> let argNames = map fst (Ivor.TT.getArgTypes ty) -> fail $ "Not finished yet " ++ show rule -> where getRule dir (App (App (App (App -> (Name _ eq) Placeholder) Placeholder) l) r) -> | eq == opFn JMEq = if dir then return (l, r) else return (r,l) -> getRule _ _ = fail "Not a rewrite rule" - -> rewriteAll tm dir _ _ = fail "Not a rewrite rule name" - -> showCtxtState :: Ctxt IvorFun -> Context -> String -> showCtxtState raw ctxt -> | not (proving ctxt) = "" -> | null (getGoals ctxt) = "\nNo more goals\n" -> | otherwise = let (g:gs) = getGoals ctxt in -> "\n" ++ showGoalState g ++ -> -- "\nOther goals: " ++ show gs ++ -> "\n\n" -> where -> showTm t = showImp False (unIvor raw (view t)) -> showGoalState :: Goal -> String -> showGoalState g = let (Right gd) = goalData ctxt True g -> env = bindings gd -> ty = goalType gd -> nm = goalName gd in -> showEnv (reverse env) ++ "\n" ++ -> "--------------------------------\n" ++ -> show nm ++ " ? " ++ showTm ty ++ "\n" -> showEnv [] = "" -> showEnv ((n,ty):xs) = show n ++ " : " ++ showTm ty ++ "\n" ++ -> showEnv xs - -Apply a tactic computed by an ivor function (see libs/tactics.idr for construction -of these tactics) - -> doIvor :: Context -> IO Context -> doIvor ctxt = do s <- runShell "Ivor> " (newShell ctxt) -> return (getContext s) - - --------- Specialised tactics for Idris -------- - -Given a term of type T args and a goal of type T args', look for the -first difference between args and args', and rewrite by -Suspend_Disbelief arg arg'. Keep doing this until the value solves the goal, -or there is nothing to rewrite. - -At least make sure arg and arg' and not Types, so that we're only -suspending disbelief about value equalities, not polymorphic values. - -> suspend_disbelief :: Ctxt IvorFun -> ViewTerm -> Tactic -> suspend_disbelief raw val goal ctxt -> = do ty <- checkCtxt ctxt goal val -> gd <- goalData ctxt True goal -> let gtype = view (goalType gd) -> let vtype = viewType ty -> let (gfn, gargs) = (getApp gtype, getFnArgs gtype) -> let (vfn, vargs) = (getApp vtype, getFnArgs vtype) -> when (gfn/=vfn) $ fail ((show gfn) ++ " and " ++ (show vfn) ++ -> " are different types") -> let diffs = filter (\ (x,y) -> x/=y) (zip gargs vargs) -> ctxt <- rewriteDiffs diffs goal ctxt -> fill val goal ctxt -> where rewriteDiffs [] goal ctxt = idTac goal ctxt -> rewriteDiffs ((arg1, arg2):ds) goal ctxt -> = do let rt = believe arg1 arg2 -> rty <- checkCtxt ctxt goal arg1 -> when (viewType rty == Star) $ -> fail ((show arg1) ++ " is a type") -> ctxt' <- rewrite rt False goal ctxt -> rewriteDiffs ds goal ctxt' - -As above, but instead of just believing the value, insert subgoals for -the required equality proofs - -> prove_belief :: Ctxt IvorFun -> ViewTerm -> Tactic -> prove_belief raw val goal ctxt -> = do ty <- checkCtxt ctxt goal val -> gd <- goalData ctxt True goal -> let gtype = view (goalType gd) -> let vtype = viewType ty -> let (gfn, gargs) = (getApp gtype, getFnArgs gtype) -> let (vfn, vargs) = (getApp vtype, getFnArgs vtype) -> when (gfn/=vfn) $ fail ((show gfn) ++ " and " ++ (show vfn) ++ -> " are different types") -> let diffs = filter (\ (x,y) -> x/=y) (zip gargs vargs) -> ctxt <- rewriteDiffs diffs goal ctxt -> fill val goal ctxt -> where rewriteDiffs [] goal ctxt = idTac goal ctxt -> rewriteDiffs ((arg1, arg2):ds) goal ctxt -> = do let claimTy = eqP arg2 arg1 -> claimName <- uniqueName ctxt (name "equality") -> ctxt <- claim claimName claimTy goal ctxt -> rty <- checkCtxt ctxt goal arg1 -> when (viewType rty == Star) $ -> fail ((show arg1) ++ " is a type") -> ctxt' <- rewrite (Name Unknown claimName) False goal ctxt -> rewriteDiffs ds goal ctxt' - -decide; given a goal of the form X a b c, and a function x of type -x : a:A -> b:B -> c:C -> (Maybe (X a b c), apply the function to -a b c, and send the result to Ivor's isItJust tactic - -_or_; given a goal of the form X a b c, and a function x of type -x: a:A -> b:B -> c:C -> Tactic, send x a b c to runtac below. - -> decide :: Ctxt IvorFun -> UserOps -> RawTerm -> Tactic -> decide raw uo dproc goal ctxt = do -> gd <- goalData ctxt True goal -> let idgoal = unIvor raw ((view.goalType) gd) -> let args = getExplicitArgs idgoal -> let dapp = makeIvorTerm noImplicit defDo uo (UN "__prf") raw -> (mkApp "[proof]" 0 dproc args) -> (isItJust dapp >|> runtac raw uo dapp) goal ctxt - -Try to solve a goal by looking through the global context. Obviously, this is -a bit dumb. - -This is intended for type classes, so perhaps eventually what we'll want is -a way of just searching for dictionaries. - -> simplesearch :: Ctxt IvorFun -> UserOps -> Tactic -> simplesearch raw uo goal ctxt = tryAll 5 allns goal ctxt -> where tryAll 0 _ _ _ = ttfail "Can't find a solution" -> tryAll d [] g c = ttfail "Can't find a solution" -> tryAll d ((i,fn):rest) g c | isFun (ivorDef fn) && take 8 (show i) == "instance" -> = (tryRefine d (show i) >|> tryAll d rest) g c -> tryAll d (_:rest) g c = tryAll d rest g c - -> isFun (Just (SimpleDef _)) = True -> isFun (Just (PattDef _)) = True -> isFun _ = False -> allns = ctxtAlist raw - -> tryRefine d n g c = do goald <- goalData c False defaultGoal -> c <- refine n g c -> if (allSolved c) then return c else -> (beta >-> tryAll (d-1) allns) defaultGoal c - - - -Run a tactic computed by mkTac - -Check the term actually computes a tactic, then evaluate it, then run the actual tactics -the result term tells us to run. - -> runtac :: Ctxt IvorFun -> UserOps -> ViewTerm -> Tactic -> runtac raw uo tmin goal ctxt = -> do tm <- checkCtxt ctxt goal tmin -> checkTac (viewType tm) -> tm' <- evalCtxt ctxt goal tm -> exect (view tm') goal ctxt - -> where checkTac (Name _ n) | n == (name "Tactic") = return () -> checkTac ty = fail $ (show ty) ++ " is not of type Tactic" - -> exect t g c = do c' <- exect' t g c -> c' <- keepSolving defaultGoal c' -> if ((numUnsolved c') > 0) -> then beta defaultGoal c' -> else return c' - -> exect' (App (App (Name _ tthen) x) y) | tthen == name "TThen" -> = exect x >+> exect y -> exect' (App (App (Name _ tseq) x) y) | tseq == name "TSeq" -> = exect x >-> exect y -> exect' (App (App (Name _ tthen) x) y) | tthen == name "TThenAll" -> = exect x >=> exect y -> exect' (App (App (Name _ ttry) x) y) | ttry == name "TTry" -> = exect x >|> exect y -> exect' (App (App (Name _ tfill) _) y) | tfill == name "TFill" -> = fill y >+> keepSolving -> exect' (App (App (Name _ tdecide) _) y) | tdecide == name "TDecide" -> = isItJust y >+> keepSolving -> exect' (App (Name _ trefine) (Constant s)) | trefine == name "TRefine" = -> case cast s :: Maybe String of -> Just str -> refine str -> exect' (App (Name _ tfail) (Constant s)) | tfail == name "TFail" = -> \ g c -> case cast s :: Maybe String of -> Just err -> ttfail err -> exect' (Name _ ttrivial) | ttrivial == name "TTrivial" = trivial >|> refine reflN -> exect' (Name _ ttrivial) | ttrivial == name "TSearchContext" = trivial >|> simplesearch raw uo >|> refine reflN -> exect' tm = \ g c -> ttfail $ "Couldn't compute tactic " ++ show tm - -XXX: Auto-rewrite: user can add rewrite rules, auto-rewrite repeatedly -rewrites by these rules until there's no more to rewrite, or until a -threshold is reached. Effectively looking for some kind of normal -form. Can we do this in any reasonable way? diff --git a/Idris/RunIO.hs b/Idris/RunIO.hs deleted file mode 100644 --- a/Idris/RunIO.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-} -{-# LANGUAGE MagicHash, UndecidableInstances, OverlappingInstances #-} - -module Idris.RunIO where - --- import SimplDSL - -import Ivor.TT -import Ivor.Shell -import Ivor.Construction -import Idris.AbsSyntax - -import Data.Typeable -import Data.IORef -import System.IO.Unsafe -import System.IO -import Control.Monad.Error -import Control.Concurrent -import Debug.Trace - -newtype Lock = Lock QSem - -instance Typeable Lock where - typeOf a = mkTyConApp (mkTyCon "Lock") [] - -instance Show Lock where - show x = "<>" - -instance Eq Lock where - (==) x y = False -- Hmm - -instance ViewConst Handle where - typeof x = (name "Handle") - -instance ViewConst Lock where - typeof x = (name "Lock") - -exec :: Context -> Term -> IO () -exec ctxt wurzel = do res <- runIO ctxt (view (whnf ctxt wurzel)) - putStrLn $ show res - -runIO :: Context -> ViewTerm -> IO ViewTerm -runIO ctxt (App (App (App (Name _ d) _) act) k) - | d == name "IO.IODo" = runAction ctxt (parseAction act) k -runIO ctxt (App (App (Name _ l) _) res) - | l == name "IO.IOReturn" = return res -runIO _ x = fail $ "Not an IO action: " ++ show x - -data Action = ReadStr - | WriteStr String - | Fork ViewTerm - | NewLock Int - | DoLock Lock - | DoUnlock Lock - | NewRef - | ReadRef Int - | WriteRef Int ViewTerm - | CantReduce ViewTerm - -parseAction x = parseAction' x [] where - parseAction' (App f a) args = parseAction' f (a:args) - parseAction' (Name _ n) args = (getAction n args) - -getAction n [] - | n == name "IO.GetStr" = ReadStr -getAction n [Constant str] - | n == name "IO.PutStr" - = case cast str of - Just str' -> WriteStr str' -getAction n [_,t] - | n == name "IO.Fork" - = Fork t -getAction n [Constant i] - | n == name "IO.NewLock" - = case cast i of - Just i' -> NewLock i' -getAction n [lock] - | n == name "IO.DoLock" - = DoLock (getLock lock) - | n == name "IO.DoUnlock" - = DoUnlock (getLock lock) -getAction n [] - | n == name "IO.NewRef" = NewRef -getAction n [_,Constant i] - | n == name "IO.ReadRef" - = case cast i of - Just i' -> ReadRef i' -getAction n [_,Constant i,val] - | n == name "IO.WriteRef" - = case cast i of - Just i' -> WriteRef i' val - -getAction n args = CantReduce (apply (Name Unknown n) args) - -getHandle (App _ (Constant h)) = case cast h of - Just h' -> h' -getLock (Constant h) = case cast h of - Just h' -> h' - Nothing -> error ("Lock error in constant " ++ show h) -getLock x = error ("Lock error " ++ show x) - -continue ctxt k arg = case fastCheck ctxt (App k arg) of - t -> let next = whnf ctxt t in - runIO ctxt (view next) -{- Right t -> let next = whnf ctxt t in - runIO ctxt (view next) - Left err -> fail $ "Can't happen - continue " ++ err ++ "\n" ++ show k ++ "\n" ++ show arg --} - -unit = Name Unknown (name "II") - -runAction ctxt (WriteStr str) k - -- Print the string, then run the continuation with the argument 'II' - = do putStr str - hFlush stdout - continue ctxt k unit -runAction ctxt ReadStr k - -- Read a string then run the continuation with the constant str - = do str <- getLine - continue ctxt k (Constant str) -runAction ctxt (Fork t) k - = do forkIO (do x <- runIO ctxt t - return ()) - continue ctxt k unit -runAction ctxt (NewLock n) k - = do mv <- newQSem n - continue ctxt k (Constant (Lock mv)) -runAction ctxt (DoLock l) k - = do primLock l - continue ctxt k unit -runAction ctxt (DoUnlock l) k - = do primUnlock l - continue ctxt k unit -runAction ctxt NewRef k - = do i <- newRef - continue ctxt k (Constant i) -runAction ctxt (ReadRef i) k - = do v <- getMem i - continue ctxt k v -runAction ctxt (WriteRef i val) k - = do putMem i val - continue ctxt k unit -runAction ctxt (CantReduce t) k - = do fail $ "Stuck at: " ++ show t - -- hFlush stdout - -primLock :: Lock -> IO () -primLock (Lock lock) = do waitQSem lock - -primUnlock :: Lock -> IO () -primUnlock (Lock lock) = signalQSem lock - - --- Some mutable memory, for implementing IORefs idris side. - -type Value = ViewTerm -defaultVal = (Constant (0xDEADBEEF::Int)) - -data MemState = MemState (IORef (Int, [Value])) - -memory :: MemState -memory = unsafePerformIO - (do mem <- newIORef (0, (take 100 (repeat defaultVal))) - return (MemState mem)) - -newRef :: IO Int -newRef = do let (MemState mem) = memory - (p,ref) <- readIORef mem - writeIORef mem (p+1, ref) - return p - -putMem :: Int -> Value -> IO () -putMem loc val = do let (MemState mem) = memory - (p,content) <- readIORef mem - writeIORef mem (p, update content loc val) - -getMem :: Int -> IO Value -getMem loc = do let (MemState mem) = memory - (p, content) <- readIORef mem - return (content!!!(loc, "getMem fail")) - -update :: [a] -> Int -> a -> [a] -update [] _ _ = [] -update (x:xs) 0 v = (v:xs) -update (x:xs) n v = x:(update xs (n-1) v) diff --git a/Idris/SCTrans.lhs b/Idris/SCTrans.lhs deleted file mode 100644 --- a/Idris/SCTrans.lhs +++ /dev/null @@ -1,175 +0,0 @@ -> {-# OPTIONS_GHC -fglasgow-exts #-} - -Transformations at the supercombinator level. - -Includes transforming data types into special case more efficient versions. -e.g. Nat -> Int, possibly List -> Block of memory, etc. - -NOTE: Anything which has the shape of Nat, e.g. Fin could be converted to Nat -at an earlier stage, e.g. in ConTrans phase, then these transformations -would take effect. - -> module Idris.SCTrans(transformSC, applyTransformsSC, SCTrans(..)) where - -> import Idris.AbsSyntax -> import Idris.LambdaLift - -> import Ivor.TT - -> import Maybe -> import Debug.Trace - -> data SCTrans = SCTrans String (SCBody -> SCBody) - -> allSCTrans = [cfold, natCons, natCase, boolCons, boolCase, natArith, cfold] - -Easier to take 'erasure' as an argument here - don't do constructor -transformations if we're not doing erasure (could do others). - -> transformSC :: Bool -> SCFun -> SCFun -> transformSC erasure (SCFun c ns b) = SCFun c ns (tr b) where -> tr tm = if erasure then applyTransformsSC allSCTrans tm -> else tm - -> applyTransformsSC :: [SCTrans] -> SCBody -> SCBody -> applyTransformsSC ts tm = foldl (flip doTrans) tm ts - -Built-in transformations. - -* Constant folding - -> cfold = SCTrans "Constant Folding" con where -> con (SInfix op (SConst (Num x)) (SConst (Num y))) -> | Just r <- runOp op x y = SConst (Num r) -> con x = x -> runOp Plus x y = Just $ x+y -> runOp Minus x y = Just $ x-y -> runOp Times x y = Just $ x*y -> runOp Divide x y = Just $ x `div` y -> runOp _ x y = Nothing - -* Nat constructors - -> natCons = SCTrans "NatCons" ncon where -> ncon (SApp (SCon succ t) [arg]) -> | succ == name "S" = SInfix Plus (SConst (Num 1)) arg -> ncon (SCon zero t) -> | zero == name "O" = SConst (Num 0) -> ncon x = x - -* Nat function special cases - -> natArith = SCTrans "NatArith" narith where -> narith (SApp (SVar op) [x,y]) - -Arithmetic can use machine operations - -> | op == name "plus" = SInfix Plus x y -> | op == name "mult" = SInfix Times x y - -Conversions between nat and int are just no-ops - -> narith (SApp (SVar op) [x]) -> | op == name "natToInt" = x -> | op == name "intToNat" = x - -> narith x = x - -* Nat destructor (case) - -> natCase = SCTrans "NatCase" ncase where -> ncase x@(SCCase t alts) -> = case getNatAlts alts of -> (Just z, Just (arg, s), _) -> mkNatRHS t z (doSuc arg t s) -> (Just z, Nothing, Just d) -> mkNatRHS t z d -> (Nothing, Just (arg, s), Just d) -> mkNatRHS t d (doSuc arg t s) -> (Nothing, Nothing, Just d) -> x -> _ -> x -> ncase x = x - -if t==0 then z else s - -> mkNatRHS t z s = SIfZero t z s - -let arg = t - 1 in s - -> doSuc arg t s = SLet arg (SInfix Minus t (SConst (Num 1))) s - -> getNatAlts alts = let zs = mHead (mapMaybe getZeroAlt alts) -> ss = mHead (mapMaybe getSuccAlt alts) -> defs = mHead (mapMaybe getDefault alts) in -> (zs, ss, defs) -> -> mHead [x] = Just x -> mHead [] = Nothing -> getZeroAlt (SAlt zero t [] zrhs) -> | zero == name "O" = return zrhs -> getZeroAlt _ = fail "no O" -> getSuccAlt (SAlt succ t [arg] srhs) -> | succ == name "S" = return (arg, srhs) -> getSuccAlt _ = fail "no S" -> getDefault (SDefault drhs) = return drhs -> getDefault _ = fail "no default" - - -[SAlt zero t [] zrhs]] -[SAlt succ t [arg] shrs] -[SAlt zero t [] zrhs, SAlt succ t [arg] shrs, _] - -* Bool constructors - -> boolCons = SCTrans "BoolCons" ncon where -> ncon (SCon true t) -> | true == name "True" = SConst (Num 1) -> ncon (SCon false t) -> | false == name "False" = SConst (Num 0) -> ncon x = x - -* Bool destructor (case) - -> boolCase = SCTrans "BoolCase" bcase where -> bcase x@(SCCase t alts) -> = case getBoolAlts alts of -> (Just fc, Just tc, _) -> mkBoolRHS t fc tc -> (Just fc, Nothing, Just d) -> mkBoolRHS t fc d -> (Nothing, Just tc, Just d) -> mkBoolRHS t d tc -> (Nothing, Nothing, Just d) -> x -> _ -> x -> bcase x = x - -> mkBoolRHS t z s = SIfZero t z s - -> getBoolAlts alts = let fs = mHead (mapMaybe getFalseAlt alts) -> ts = mHead (mapMaybe getTrueAlt alts) -> defs = mHead (mapMaybe getDefault alts) in -> (fs, ts, defs) -> -> mHead [x] = Just x -> mHead [] = Nothing - -> getFalseAlt (SAlt false t [] frhs) -> | false == name "False" = return frhs -> getFalseAlt _ = fail "no O" -> getTrueAlt (SAlt true t [] trhs) -> | true == name "True" = return trhs -> getTrueAlt _ = fail "no True" -> getDefault (SDefault drhs) = return drhs -> getDefault _ = fail "no default" - -> doTrans :: SCTrans -> SCBody -> SCBody -> doTrans (SCTrans _ trans) tm = tr tm where -> tr (SApp b bs) = trans (SApp (tr b) (map tr bs)) -> tr (SLet n v sc) = trans (SLet n (tr v) (tr sc)) -> tr (SCCase b alts) = trans (SCCase (tr b) (map tralt alts)) -> tr (SInfix op l r) = trans (SInfix op (tr l) (tr r)) -> tr (SLazy s) = trans (SLazy (tr s)) -> tr (SIf i t e) = trans (SIf (tr i) (tr t) (tr e)) -> tr (SIfZero i t e) = trans (SIfZero (tr i) (tr t) (tr e)) -> tr s = trans s - -> tralt (SAlt n t args rhs) = SAlt n t args (tr rhs) -> tralt (SConstAlt c rhs) = SConstAlt c (tr rhs) -> tralt (SDefault rhs) = SDefault (tr rhs) - - - diff --git a/Idris/Serialise.lhs b/Idris/Serialise.lhs deleted file mode 100644 --- a/Idris/Serialise.lhs +++ /dev/null @@ -1,406 +0,0 @@ -> {-# OPTIONS_GHC -fglasgow-exts #-} - -Binary instances for idris data structures, and saving and loading -typechecked forms to disk. - -> module Idris.Serialise where - -> import Idris.AbsSyntax -> import Idris.ConTrans -> import Ivor.ViewTerm -> import Ivor.TT - -> import Data.Binary -> import Data.Typeable -> import Control.Monad - -> import Debug.Trace - -> instance Binary ViewTerm where -> put (Name t x) = do put (0 :: Word8) -> put t; put x -> put (App f a) = do put (1 :: Word8) -> put f; put a -> put (Lambda v ty sc) = do put (2 :: Word8) -> put v; put ty; put sc -> put (Forall v ty sc) = do put (3 :: Word8) -> put v; put ty; put sc -> put (Let n v ty sc) = do put (4 :: Word8) -> put n; put v; put ty; put sc -> put Star = put (5 :: Word8) -> put Placeholder = put (6 :: Word8) -> put (Annotation a t) = do put (7 :: Word8) -> put a; put t -> put (Metavar m) = do put (8 :: Word8) -> put m -> put (Constant c) = case cast c :: Maybe String of -> Just v -> do put (9 :: Word8) -> put v -> Nothing -> case cast c :: Maybe Int of -> Just v -> do put (10 :: Word8) -> put v -> Nothing -> case cast c :: Maybe Double of -> Just v -> do put (11 :: Word8) -> put v -> Nothing -> case cast c :: Maybe Char of -> Just v -> do put (12 :: Word8) -> put v -> Nothing -> fail "Unknown constant type" - -> get = do tag <- getWord8 -> case tag of -> 0 -> liftM2 Name get get -> 1 -> liftM2 App get get -> 2 -> liftM3 Lambda get get get -> 3 -> liftM3 Forall get get get -> 4 -> liftM4 Let get get get get -> 5 -> return Star -> 6 -> return Placeholder -> 7 -> liftM2 Annotation get get -> 8 -> liftM Metavar get -> 9 -> do s <- get -> return (Constant (s :: String)) -> 10 -> do i <- get -> return (Constant (i :: Int)) -> 11 -> do d <- get -> return (Constant (d :: Double)) -> 12 -> do d <- get -> return (Constant (d :: Char)) - - -> instance Binary RBinder where -> put (Pi p l r) = do put (0 :: Word8) -> put p; put l; put r -> put (Lam t) = do put (1 :: Word8); put t -> put (RLet t ty) = do put (2 :: Word8); put t; put ty - -> get = do tag <- getWord8 -> case tag of -> 0 -> liftM3 Pi get get get -> 1 -> liftM Lam get -> 2 -> liftM2 RLet get get - -> instance Binary Op where -> put x = put (fromEnum x) -> get = do t <- get -> return (toEnum t) - -> instance Binary Plicit where -> put x = put (fromEnum x) -> get = do t <- get -> return (toEnum t) - -> instance Binary Fixity where -> put x = put (fromEnum x) -> get = do t <- get -> return (toEnum t) - -> instance Binary Opt where -> put x = put (fromEnum x) -> get = do t <- get -> return (toEnum t) - -> instance Binary TyOpt where -> put x = put (fromEnum x) -> get = do t <- get -> return (toEnum t) - -> instance Binary ArgOpt where -> put x = put (fromEnum x) -> get = do t <- get -> return (toEnum t) - -> instance Binary Do where -> put (DoBinding f l i t y) = do put (0 :: Word8) -> put f; put l; put i; put t; put y -> put (DoLet a b c d e) = do put (1 :: Word8) -> put a; put b; put c; put d; put e -> put (DoExp a b c) = do put (2 :: Word8); put a; put b; put c - -> get = do tag <- getWord8 -> case tag of -> 0 -> liftM5 DoBinding get get get get get -> 1 -> liftM5 DoLet get get get get get -> 2 -> liftM3 DoExp get get get - -> instance Binary RawTerm where -> put (RVar a b c d) = do put (0 :: Word8); put a; put b; put c; put d -> put (RExpVar a b c) = do put (1 :: Word8); put a; put b; put c -> put (RApp a b c d) = do put (2 :: Word8); put a; put b; put c; put d -> put (RAppImp a b c d e) -> = do put (3 :: Word8); put a; put b; put c; put d; put e -> put (RBind a b c) = do put (4 :: Word8); put a; put b; put c -> put (RConst a b c) = do put (5 :: Word8); put a; put b; put c -> put RPlaceholder = put (6 :: Word8) -> put (RMetavar i) = do put (7 :: Word8); put i -> put (RInfix a b c d e) -> = do put (8 :: Word8); put a; put b; put c; put d; put e -> put (RUserInfix a b c d e f) -> = do put (9 :: Word8); put a; put b; put c; put d; put e; put f -> put (RDo xs) = do put (10 :: Word8); put xs -> put (RReturn a b) = do put (11 :: Word8); put a; put b -> put (RIdiom i) = do put (12 :: Word8); put i -> put (RPure i) = do put (13 :: Word8); put i -> put RRefl = do put (14 :: Word8) -> put (RError f l i) = do put (15 :: Word8); put f; put l; put i - -> get = do tag <- getWord8 -> case tag of -> 0 -> liftM4 RVar get get get get -> 1 -> liftM3 RExpVar get get get -> 2 -> liftM4 RApp get get get get -> 3 -> liftM5 RAppImp get get get get get -> 4 -> liftM3 RBind get get get -> 5 -> liftM3 RConst get get get -> 6 -> return RPlaceholder -> 7 -> liftM RMetavar get -> 8 -> liftM5 RInfix get get get get get -> 9 -> do a <- get; b <- get; c <- get; d <- get; e <- get; -> f <- get; -> return $ RUserInfix a b c d e f -> 10 -> liftM RDo get -> 11 -> liftM2 RReturn get get -> 12 -> liftM RIdiom get -> 13 -> liftM RPure get -> 14 -> return RRefl -> 15 -> liftM3 RError get get get - -> instance Binary Constant where -> put (Num i) = do put (0 :: Word8); put i -> put (Str i) = do put (1 :: Word8); put i -> put (Bo b) = do put (2 :: Word8); put b -> put (Ch c) = do put (3 :: Word8); put c -> put (Fl f) = do put (4 :: Word8); put f -> put TYPE = put (5 :: Word8) -> put StringType = put (6 :: Word8) -> put IntType = put (7 :: Word8) -> put FloatType = put (8 :: Word8) -> put CharType = put (9 :: Word8) -> put PtrType = put (10 :: Word8) -> put (Builtin i) = do put (11 :: Word8); put i - -> get = do tag <- getWord8 -> case tag of -> 0 -> liftM Num get -> 1 -> liftM Str get -> 2 -> liftM Bo get -> 3 -> liftM Ch get -> 4 -> liftM Fl get -> 5 -> return TYPE -> 6 -> return StringType -> 7 -> return IntType -> 8 -> return FloatType -> 9 -> return CharType -> 10 -> return PtrType -> 11 -> liftM Builtin get - -> instance Binary TransData where -> put (Force a b c d e f) = do put (0 :: Word8) -> put a; put b; put c; put d; put e; put f -> put (Collapse a b c d) = do put (1 :: Word8) -> put a; put b; put c; put d -> put (Drop a b c d) = do put (2 :: Word8) -> put a; put b; put c; put d -> get = do tag <- getWord8 -> case tag of -> 0 -> do a <- get; b <- get; c <- get; d <- get; -> e <- get; f <- get; -> return (Force a b c d e f) -> 1 -> liftM4 Collapse get get get get -> 2 -> liftM4 Drop get get get get - -> instance Binary Transform where -> put (Trans n _ a) = do put n; put a -> get = do n <- get; a <- get -> let trans = case a of -> Nothing -> Nothing -> Just a' -> Just (rebuildTrans a') -> return (Trans n trans a) - -> instance Binary Syntax where -> put (Syntax f n t) = do put f; put n; put t -> get = liftM3 Syntax get get get - -> instance Binary UserOps where -> put (UO ds ts f s) = do put ds; put ts; put f; put s -> get = do ds <- get; ts <- get; f <- get; s <- get; -> return (UO ds ts f s) - -> instance Binary IvorFun where -> put (IvorFun a b c d e f g h) = -> do trace ("Put " ++ show (a, d)) $ put a; put b; put c; put d; put e; put f; put g; put h -> get = do a <- get; b <- trace (show a) $ get; c <- get; d <- get; e <- get; f <- get; g <- get; h <- get -> trace ("Got " ++ show (a, d)) $ return (IvorFun a b c d e f g h) - -> instance Binary CGFlag where -> put NoCG = put (0 :: Word8) -> put CGEval = put (1 :: Word8) -> put (CExport s) = do put (2 :: Word8); put s -> put Inline = put (3 :: Word8) -> put (CGSpec x) = do put (4 :: Word8); put x - -> get = do tag <- getWord8 -> case tag of -> 0 -> return NoCG -> 1 -> return CGEval -> 2 -> liftM CExport get -> 3 -> return Inline -> 4 -> liftM CGSpec get - -> instance Binary Decl where -> put (DataDecl d) = do put (0 :: Word8); put d -> put (Fwd a b c) = do put (1 :: Word8); put a; put b; put c -> put (Fun a b) = do put (2 :: Word8); put a; put b -> put (TermDef a b c) = do put (3 :: Word8); put a; put b; put c -> put Constructor = put (4 :: Word8) -> put (Prf d f) = do put (5 :: Word8); put d; put f -> put (LatexDefs d) = do put (6 :: Word8); put d -> put (Using a b) = do put (7 :: Word8); put a; put b -> put (Params a b) = do put (8 :: Word8); put a; put b -> put (DoUsing a b c) = do put (9 :: Word8); put a; put b; put c -> put (Idiom a b c) = do put (10 :: Word8); put a; put b; put c -> put (CLib d) = do put (11 :: Word8); put d -> put (CInclude d) = do put (12 :: Word8); put d -> put (Fixity a b c) = do put (13 :: Word8); put a; put b; put c -> put (Transform a b) = do put (14 :: Word8); put a; put b -> put (Freeze a b c d) = do put (15 :: Word8); put a; put b; put c; put d -> put (SynDef a b c) = do put (16 :: Word8); put a; put b; put c -> put (PInclude a) = do put (17 :: Word8); put a -> put (Namespace a b) = do put (18 :: Word8); put a; put b - -> get = do tag <- getWord8 -> case tag of -> 0 -> liftM DataDecl get -> 1 -> liftM3 Fwd get get get -> 2 -> liftM2 Fun get get -> 3 -> liftM3 TermDef get get get -> 4 -> return Constructor -> 5 -> liftM2 Prf get get -> 6 -> liftM LatexDefs get -> 7 -> liftM2 Using get get -> 8 -> liftM2 Params get get -> 9 -> liftM3 DoUsing get get get -> 10 -> liftM3 Idiom get get get -> 11 -> liftM CLib get -> 12 -> liftM CInclude get -> 13 -> liftM3 Fixity get get get -> 14 -> liftM2 Transform get get -> 15 -> liftM4 Freeze get get get get -> 16 -> liftM3 SynDef get get get -> 17 -> liftM PInclude get -> 18 -> liftM2 Namespace get get - -> instance Binary Datatype where -> put (Datatype a b c d e f g) = do put (0 :: Word8) -> put a; put b; put c; put d; put e; -> put f; put g; -> put (Latatype a b c d) = do put (1 :: Word8) -> put a; put b; put c; put d -> get = do tag <- getWord8 -> case tag of -> 0 -> do a <- get; b <- get; c <- get; d <- get; -> e <- get; f <- get; g <- get; -> return (Datatype a b c d e f g) -> 1 -> liftM4 Latatype get get get get - -> instance Binary Function where -> put (Function a b c d e) = do put a; put b; put c; put d; put e -> get = liftM5 Function get get get get get - -> instance Binary Proof where -> put (Proof a b c) = do put a; put b; put c -> get = liftM3 Proof get get get - -> instance Binary RawClause where -> put (RawClause a b) = do put (0 :: Word8); put a; put b -> put (RawWithClause a b c d) = do put (1 :: Word8); put a; put b; put c; put d -> get = do tag <- getWord8 -> case tag of -> 0 -> liftM2 RawClause get get -> 1 -> liftM4 RawWithClause get get get get - -> instance Binary Patterns where -> put (Patterns p) = put p -> get = liftM Patterns get - -> instance Binary PClause where -> put (PClause a b c) = do put (0 :: Word8); put a; put b; put c -> put (PWithClause a b c d) = do put (1 :: Word8); put a; put b; put c; put d -> get = do tag <- getWord8 -> case tag of -> 0 -> liftM3 PClause get get get -> 1 -> liftM4 PWithClause get get get get - -> instance Binary Inductive where -> put (Inductive a b c d e) = do put a; put b; put c; put d; put e -> get = liftM5 Inductive get get get get get - -> instance Binary ITactic where -> put (Intro a) = do put (0 :: Word8); put a -> put (Refine a) = do put (1 :: Word8); put a -> put (Generalise a) = do put (2 :: Word8); put a -> put ReflP = put (3 :: Word8) -> put (Induction a) = do put (4 :: Word8); put a -> put (Fill a) = do put (5 :: Word8); put a -> put Trivial = put (6 :: Word8) -> put (Idris.AbsSyntax.Case a) = do put (7 :: Word8); put a -> put (Rewrite a b c) = do put (8 :: Word8); put a; put b; put c -> put (Unfold a) = do put (9 :: Word8); put a -> put Compute = put (10 :: Word8) -> put (Equiv a) = do put (11 :: Word8); put a -> put (Believe a) = do put (12 :: Word8); put a -> put (Use a) = do put (13 :: Word8); put a -> put (Decide a) = do put (14 :: Word8); put a -> put (RunTactic a) = do put (15 :: Word8); put a -> put Qed = put (16 :: Word8) - -> get = do tag <- getWord8 -> case tag of -> 0 -> liftM Intro get -> 1 -> liftM Refine get -> 2 -> liftM Generalise get -> 3 -> return ReflP -> 4 -> liftM Induction get -> 5 -> liftM Fill get -> 6 -> return Trivial -> 7 -> liftM Idris.AbsSyntax.Case get -> 8 -> liftM3 Rewrite get get get -> 9 -> liftM Unfold get -> 10 -> return Compute -> 11 -> liftM Equiv get -> 12 -> liftM Believe get -> 13 -> liftM Use get -> 14 -> liftM Decide get -> 15 -> liftM RunTactic get -> 16 -> return Qed - -> instance Binary IvorDef where -> put (PattDef ps) = do put (0 :: Word8); put ps -> put ITyCon = put (1 :: Word8) -> put IDataCon = put (2 :: Word8) -> put (SimpleDef t) = do put (3 :: Word8); put t -> put (DataDef a b) = do put (4 :: Word8); put a; put b -> put (IProof ts f) = do put (5 :: Word8); put ts; put f -> put Later = put (6 :: Word8) -> put LataDef = put (7 :: Word8) - -> get = do tag <- getWord8 -> case tag of -> 0 -> liftM PattDef get -> 1 -> return ITyCon -> 2 -> return IDataCon -> 3 -> liftM SimpleDef get -> 4 -> liftM2 DataDef get get -> 5 -> liftM2 IProof get get -> 6 -> return Later -> 7 -> return LataDef - -> instance Binary IdrisState where -> put (IState a b c d e f g h i j k) -> = do put a; put b; put c; put d; put e; put f; put g; put h; -> put i; put j; put k -> get = do a <- get; b <- get; c <- get; -> d <- get; e <- get; f <- get; g <- get; h <- get; i <- get -> j <- get; k <- get -> return (IState a b c d e f g h i j k) - diff --git a/Idris/SimpleCase.lhs b/Idris/SimpleCase.lhs deleted file mode 100644 --- a/Idris/SimpleCase.lhs +++ /dev/null @@ -1,135 +0,0 @@ -> {-# OPTIONS_GHC -fglasgow-exts #-} - -> module Idris.SimpleCase(liftCases, addPatternDefSC, addMeta) where - -> import Idris.AbsSyntax - -> import Ivor.ViewTerm -> import Ivor.TT - -> import Control.Monad.State -> import Debug.Trace - -> type LCState = (Int, [(Name, ViewTerm, Patterns)]) - -> liftCases :: Name -> Patterns -> (Patterns, [(Name, ViewTerm, Patterns)]) -> liftCases n ps -> = let (ps', (i, ns)) = runState (liftCasePatts n ps) (10000, []) in -> {- trace (show (ps', ns)) $ -} (ps', ns) - -> liftCasePatts :: Name -> Patterns -> -> State LCState Patterns -> liftCasePatts n (Patterns ps) -> = do ps' <- liftPs ps [] -> (_, ns) <- get -> return (Patterns ps') -> where liftPs [] acc = return acc -> liftPs ((PClause args bs rv):ps) acc -> = do rv' <- lc n bs rv -> liftPs ps (acc ++ [PClause args bs rv']) -> liftPs ((PWithClause p args sc pdefs):ps) acc -> = do sc' <- lc n [] sc -> pdefs' <- liftCasePatts n pdefs -> liftPs ps (acc ++ [PWithClause p args sc' pdefs']) - - -> lc :: Name -> [(Name, ViewTerm)] -> ViewTerm -> State LCState ViewTerm -> lc root bs = lc' where -> lc' tm | Name nty fn <- getApp tm -> = let args = getFnArgs tm in -> if (fn == name "__CASE" && length args == 4)then -> do (i, fns) <- get -> let params = bs -> let paramArgs = map (Name Unknown) (map fst params) -> let newdef = Patterns (getNewDef paramArgs (deAnnot (args!!!(3,"FAIL3")))) -> let argtype = args!!!(0, "FAIL0") -> let rettype = args!!!(1, "FAIL1") -> let scrutinee = args!!!(2, "FAIL2") -> let newty = getNewType params argtype rettype -> let newname = name (show (MN (show root) i)) -> let newfn = (newname, newty, newdef) -> put (i+1, newfn:fns) -> -- trace (show (newname, params, newdef)) $ -> return (apply (Name Unknown newname) (paramArgs++[scrutinee])) -> else return tm -> lc' (App f a) = do f' <- lc' f; a' <- lc' a; return (App f' a') -> lc' (Lambda n t sc) -> = do t' <- lc' t; sc' <- lc' sc; return (Lambda n t' sc') -> lc' (Forall n t sc) -> = do t' <- lc' t; sc' <- lc' sc; return (Forall n t' sc') -> lc' (Let n t v sc) -> = do t' <- lc' t; v' <- lc' v; -> sc' <- lc' sc; return (Let n t' v' sc') -> lc' (Annotation a t) = do t' <- lc' t; return (Annotation a t') -> lc' x = return x - -> getNewDef :: [ViewTerm] -> ViewTerm -> [PClause] -> getNewDef ps (Let _ _ _ sc) = getNewDef ps sc -> getNewDef ps (App (App (App (App (App (Name _ branch) _) _) patt) ret) next) -> | branch == name "__BRANCH" -> = PClause (ps++[patt]) [] ret -> : getNewDef ps next -> getNewDef ps x = [] - -> getParams :: ViewTerm -> [(Name, ViewTerm)] -> getParams (App (App (App (Name _ is) ty) (Name _ n)) rest) -> | is == name "__IS" = (n, ty):getParams rest -> getParams _ = [] - -> getNewType :: [(Name, ViewTerm)] -> ViewTerm -> ViewTerm -> ViewTerm -> getNewType [] arg ret = Forall (name "__X") arg ret -> getNewType ((n,ty):ns) arg ret = Forall n ty (getNewType ns arg ret) - -> deAnnot :: ViewTerm -> ViewTerm -> deAnnot (Annotation a t) = deAnnot t -> deAnnot (App f a) = App (deAnnot f) (deAnnot a) -> deAnnot x = x - -> addPatternDefSC :: Context -> Name -> ViewTerm -> Patterns -> -> Maybe [(Name, Int)] -> Statics -> -> TTM (Context, [(Name, ViewTerm)]) -> addPatternDefSC ctxt nm ty ps specopts sts = do -> -- just allow general recursion for now -> let opts = [Holey, Partial, GenRec] - -case specopts of - Nothing -> [Holey, Partial, GenRec] - Just fns -> trace ("Specialising " ++ show nm ++ " with " ++ show (map mkss sts)) $ - [Holey, Partial, GenRec], Specialise fns, - SpecStatic (map mkss sts)] - -> (ctxt', newdefs) <- addPatternDef ctxt nm ty ps opts -> ctxt' <- case specopts of -> Nothing -> return ctxt' -> Just fns -> trace ("Specialising " ++ show nm ++ " with " ++ show (map mkss sts)) $ -> spec ctxt' nm (map mkss sts) (map fst fns) -> (_, patts) <- getPatternDef ctxt' nm -> let (ps', ds) = liftCases nm patts -> if (null ds) then return (ctxt', newdefs) -> else do -> (ctxt', newdefs) <- addAll ctxt ds [] -> (ctxt', newdefs') <- addPatternDef ctxt' nm ty ps' [Holey,Partial,GenRec] -> return (ctxt', newdefs++newdefs') -> where addAll ctxt [] nds = return (ctxt, nds) -> addAll ctxt ((n,ty,ps):rs) nds = do -> (ctxt', newdefs') <- addPatternDefSC ctxt n ty ps specopts sts -> addAll ctxt' rs (newdefs'++nds) -> mkss (n, (statics, arity, ty)) = (n, (statics, arity)) - -> addMeta :: Bool -> -> Ctxt IvorFun -> Context -> -> [(Name, ViewTerm)] -> [(Name, ViewTerm)] -> -> TTM (Context, [(Name, ViewTerm)]) -> addMeta verbose raw ctxt metas newdefs -> = let ans = (ctxt, metas ++ newdefs) in -> if verbose then trace ("Metavariables are:\n" ++ concat (map showDef newdefs)) $ return ans -> else return ans -> where -> showDef (n,ty) = " " ++ show n ++ " : " ++ dumpMeta (unIvor raw ty) -> ++ "\n" -> dumpMeta tm = showImp False (Idris.AbsSyntax.getRetType tm) ++ -> "\n in environment\n" ++ -> dumpArgs (Idris.AbsSyntax.getArgTypes tm) -> dumpArgs [] = "" -> dumpArgs ((n,ty):xs) = " " ++ show n ++ " : " ++showImp False ty -> ++ "\n" ++ dumpArgs xs diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2006-2010 Edwin Brady +Copyright (c) 2011 Edwin Brady School of Computer Science, University of St Andrews All rights reserved. diff --git a/Main.lhs b/Main.lhs deleted file mode 100644 --- a/Main.lhs +++ /dev/null @@ -1,719 +0,0 @@ -> module Main where - -> import Ivor.TT hiding (transform) -> import Ivor.Shell - -> import System -> import System.Environment -> import System.Time -> import System.Locale -> import System.IO -> import System.Console.Readline -> import Data.Typeable -> import Data.Binary -> import Char -> import Control.Monad -> import Control.Exception -> import List -> import Maybe -> import Debug.Trace -> import Distribution.Version -> import Prelude hiding (catch) - -> import Idris.AbsSyntax -> import Idris.MakeTerm -> import Idris.Lib -> import Idris.Parser -> import Idris.Latex -> import Idris.Compiler -> import Idris.Prover -> import Idris.ConTrans -> import Idris.Fontlock -> import Idris.Serialise -> import Idris.RunIO -> import Idris.PartialEval - -> import Paths_idris - -Load things in this order: - -* Introduce equality -* Load builtins (which don't rely on primitive types) -* Add primitives -* Load prelude -* Load users program - -> idris_version = showV (versionBranch version) -> where -> showV [] = "" -> showV [a] = show a -> showV (x:xs) = show x ++ "." ++ showV xs - -> data Args = Batch [String] -> | NoArgs - -> main :: IO () -> main = do args <- getArgs -> (infile, (batch, opts)) <- usage args -> ctxt <- ioTac $ addEquality emptyContext (name "Eq") (name "refl") -> (ctxt, defs) <- processInput ctxt (initState opts) "builtins.idr" -> ctxt <- ioTac $ prims ctxt -> (ctxt, defs) <- processInput ctxt defs "prelude.idr" -> (ctxt, defs) <- processInput ctxt defs infile -> let vars = idris_metavars defs -> when (not (null vars)) $ -> do putStr "Proof obligations:\n\t" -> print (map fst vars) -> putStr "\n" -> repl defs ctxt batch - -> usage opts@(('-':_):_) = do o <- mkArgs opts -> putStrLn "No input file" -> umessage -> usage [fname] = return (fname, (NoArgs, [])) -> usage (fname:opts) = do o <- mkArgs opts -> return (fname, o) -> usage _ = umessage - -> umessage = -> do putStrLn $ "Idris version " ++ idris_version -> putStrLn $ "--------------" ++ take (length idris_version) (repeat '-') -> putStrLn $ "Usage:" -> putStrLn $ "\tidris [options]" -> putStrLn $ "\n\tAvailable options:" -> putStrLn $ "\t\t -o Compile to an executable" -> putStrLn $ "\t\t --run Compile and run" -> putStrLn $ "\t\t --nospec Turn off specialisation and transformation rules" -> putStrLn $ "\t\t --noerasure Turn off erasure optimisations" -> putStrLn $ "\t\t --cmd Run a command in batch mode" -> putStrLn $ "\t\t --dir Show support file location" -> putStrLn $ "\t\t --verbose Debugging output" -> putStrLn $ "\n" -> exitWith (ExitFailure 1) - -> mkArgs xs = mkA' [] [] xs where -> mkA' [] opts [] = return (NoArgs, opts) -> mkA' args opts [] = return (Batch (reverse args), opts) -> mkA' args opts ("-o":output:xs) -> = mkA' ((":c " ++ output):args) opts xs -> mkA' args opts ("--run":xs) -> = mkA' (":e":args) opts xs -> mkA' args opts ("-v":xs) -> = mkA' args (Verbose:opts) xs -> mkA' args opts ("--verbose":xs) -> = mkA' args (Verbose:opts) xs -> mkA' args opts ("--nospec":xs) -> = mkA' args (NoSpec:opts) xs -> mkA' args opts ("--noerasure":xs) -> = mkA' args (NoErasure:opts) xs -> mkA' args opts ("--cmd":b:xs) -> = mkA' (b:args) opts xs -> mkA' args opts ("--dir":xs) -> = do d <- getDataDir -> putStrLn d -> exitWith ExitSuccess -> mkA' args opts (x:xs) = do putStrLn $ "Unrecognised option " ++ x ++ "\n" -> umessage - -Time functions -FIXME: These use System.Time which is deprecated. Find out what to use -these days instead... - -> picosec = 1000000000000 -> mins = picosec*60 -> hours = mins*60 -> days = hours*24 - -> getTime :: IO Integer -> getTime = do (TOD sec pico) <- getClockTime -> return $ sec*picosec+pico -> diffTime t1 t2 = t1-t2 -> showTime t = show (t `div` picosec) ++ "." ++ -> (take 6 (zeros (show (t `mod` picosec)))) ++ -> " seconds" -> -- add leading zeros -> where zeros t = (take (12 - length t) (repeat '0')) ++ t - -> processInput :: Context -> IdrisState -> FilePath -> -> IO (Context, IdrisState) -> processInput ctxt ist file = do -> let defs = idris_context ist -> let decls = idris_decls ist -> let opts = idris_options ist -> let fixes = idris_fixities ist -> let static = idris_static ist -> let sts = idris_static_used ist -> content <- readLibFile defaultLibPath file -> (ptree, imps) <- processImports opts (idris_imports ist) (parse content file) -> let (defsin, ops) = makeIvorFuns opts defs ptree fixes -> let static' = staticDecls defsin ++ static -> let defs' = defsin -- addPEdefs static' defsin -> let alldefs = appCtxt defs defs' -> ((ctxt, metas), fixes', sts') <- -> case (addIvor opts ist alldefs defs' ctxt ops static' sts) of -> OK x fixes' sts' -> return (x, fixes', sts') -> Err x fixes' sts' err -> do putStrLn err -> return (x, fixes', sts') -> let ist = addTransforms (IState alldefs (decls ++ ptree) metas opts ops [] newCtxt imps (mkNameMap alldefs) static' sts') ctxt -> return (ctxt, ist { idris_fixities = fixes' }) - -> data REPLRes = Quit | Continue | NewCtxt IdrisState Context - -Command; minimal abbreviation; function to run it; description; visibility - -> commands -> = [("quit", "q", quit, "Exits the top level",True), -> ("type", "t", tmtype, "Print the type of a term",True), -> ("prove", "p", prove, "Begin a proof of an undefined name",True), -> ("metavars", "m", metavars, -> "Show remaining proof obligations",True), -> ("ivor", "i", ivor, "Drop into the Ivor shell",True), -> ("compile", "c", tcomp, "Compile a definition (of type IO ()", True), -> ("execute", "e", texec, "Compile and execute 'main'", True), -> ("LATEX", "L", latex, "Render a source file as LaTeX",False), -> ("HTML","H", html, "Render a source file as html", False), -> ("normalise", "n", norm, "Normalise a term (without executing)", True), -> ("definition", "d", showdef, "Show the erased version of a function or type", True), -> ("options","o", options, "Set options", True), -> ("help", "h", help, "Show help text",True), -> ("save", "s", ssave, "Save system state",True), -> ("load", "l", sload, "Load system state",True), -> ("xdebug", "xd", debug, "Show some internal stuff", False), -> ("?", "?", help, "Show help text",True)] - -> type Command = IdrisState -> Context -> [String] -> IO REPLRes - -> quit, tmtype, prove, metavars, tcomp, texec :: Command -> debug, norm, help, options, showdef, html, ssave :: Command - -> quit _ _ _ = do return Quit -> tmtype (IState raw _ _ _ uo _ _ _ _ _ _) ctxt tms -> = do icheckType raw uo ctxt (unwords tms) -> return Continue -> prove ist ctxt (nm:[]) -> = do let raw = idris_context ist -> ctxt' <- doProof raw ctxt (idris_fixities ist) (UN nm) -> let imv = filter (\ (x,y) -> x /= toIvorName (UN nm)) -> (idris_metavars ist) -> let ist' = ist { idris_metavars = imv } -> return (NewCtxt ist' ctxt') -> prove ist ctxt _ = do putStrLn "What do you want to prove?" -> return Continue -> metavars ist ctxt _ -> = do let vars = idris_metavars ist -> if (null vars) -> then putStrLn "All proofs complete." -> else -> do putStr "Proof obligations:\n\t" -> print (map fst vars) -> putStr "\n" -> return Continue -> ivor ist ctxt _ = do ctxt' <- doIvor ctxt -> return (NewCtxt ist ctxt') - - latex ist ctxt (nm:defs) - = do latexDump (idris_context ist) (latexDefs defs) (UN nm) - return Continue - -> html ist ctxt (nm:onm:style:_) -> = do htmlise (idris_context ist) nm onm (Just style) -> return Continue -> html ist ctxt (nm:onm:_) -> = do htmlise (idris_context ist) nm onm Nothing -> return Continue -> html ist ctxt _ -> = do putStrLn "Please give input and output files" -> return Continue -> ssave ist ctxt (nm:_) -> = do encodeFile nm ist -> return Continue -> ssave ist ctxt _ -> = do putStrLn "Please give an output file name" -> return Continue -> sload ist ctxt (nm:_) -> = do ist' <- decodeFile nm -> return (NewCtxt ist' ctxt) -> sload ist ctxt _ -> = do putStrLn "Please give an input file name" -> return Continue -> latex ist ctxt (nm:onm:_) -> = do latexise (idris_context ist) nm onm -> return Continue -> latex ist ctxt _ -> = do putStrLn "Please give input and output files" -> return Continue -> debug ist ctxt [] -> = do putStrLn "Fixities/transforms\n" -> print (idris_fixities ist) -> putStrLn "\nStatic args:\n" -> print (idris_static ist) -> print (idris_static_used ist) -> return Continue -> tcomp ist ctxt [] -> = do putStrLn "Please give an output filename" -> return Continue -> tcomp ist ctxt (top:[]) -> = do let raw = idris_context ist -> comp ist ctxt (UN top) top -> -- putStrLn $ "Output " ++ top -> return Continue -> tcomp ist ctxt (top:exec:_) -> = do comp ist ctxt (UN top) exec -> return Continue -> texec ist ctxt _ -> = do time <- getTime -> res <- comp ist ctxt (UN "main") "main" -> ctime <- getTime -> let cdiff = diffTime ctime time -> when (ShowRunTime `elem` (idris_options ist)) -> (putStrLn $ "Compile time: " ++ showTime cdiff ++ "\n") -> when res (do system "./main" -> return ()) -> rtime <- getTime -> let rdiff = diffTime rtime ctime -> when (ShowRunTime `elem` (idris_options ist)) -> (putStrLn $ "\nRun time: " ++ showTime rdiff) -> return Continue -> norm ist ctxt tms -> = do let raw = idris_context ist -> termInput False raw (idris_fixities ist) ctxt (unwords tms) -> return Continue -> options ist ctxt [] -> = do putStrLn $ "Options: " ++ show (idris_options ist) -> return Continue -> options ist ctxt tms -> = do let opts = idris_options ist -> let ist' = addTransforms (ist { idris_options = processOpts opts tms }) ctxt -> return $ NewCtxt ist' ctxt - -> help _ _ _ -> = do putStrLn $ "\nIdris version " ++ idris_version -> putStrLn $ "----------------" ++ take (length idris_version) (repeat '-') -> putStrLn "Commands available:\n" -> putStrLn "\t Execute the given expression" -> mapM_ (\ (com, _, _, desc,vis) -> -> if vis -> then putStrLn $ "\t:" ++ com ++ (take (16-length com) (repeat ' ')) ++ desc -> else return ()) commands -> putStrLn "\nCommands may be given the shortest unambiguous abbreviation (e.g. :q, :l)\n" -> return Continue - -> repl :: IdrisState -> Context -> Args -> IO () -> repl ist ctxt (Batch []) = return () -> repl ist@(IState raw decls metas opts fixes trans syns imps nms st stu) ctxt inp' -> = do (inp, next) <- case inp' of -> Batch (b:bs) -> return (Just b, Batch bs) -> _ -> do x <- readline ("Idris> ") -> return (x, NoArgs) -> res <- case inp of -> Nothing -> -> do putChar '\n' -> return Quit -> Just (':':command) -> -> do addHistory (':':command) -> runCommand' (words command) commands -> Just exprinput -> -> do termInput' raw fixes ctxt exprinput -> addHistory exprinput -> return Continue -> case res of -> Continue -> repl ist ctxt next -> NewCtxt ist' ctxt' -> repl ist' ctxt' next -> Quit -> return () - -> where -> runCommand (c:args) ((_, abbr, fun, _, _):xs) -> | matchesAbbrev abbr c = fun ist ctxt args -> | otherwise = runCommand (c:args) xs -> runCommand _ _ = do putStrLn "Unrecognised command" -> help ist ctxt [] -> return Continue -> matchesAbbrev [] _ = True -> matchesAbbrev (a:xs) (c:cs) | a == c = matchesAbbrev xs cs -> | otherwise = False -> matchesAbbrev _ _ = False - -> termInput' r f c inp = handle handler $ termInput True r f c inp -> where handler StackOverflow = putStrLn "Stack overflow" -> handler UserInterrupt = putStrLn "Interrupted" -> handler e = print e -- throwIO e -> runCommand' w c = handle handler $ runCommand w c -> where handler e = do print (e :: IOError) -> return Continue - -> termInput runio raw uo ctxt tm -> = case getTerm tm of -> Right tm -> execEval runio raw ctxt (tm, viewType tm) -> Left err -> print err -> where getTerm tm = do let parsed' = parseTerm tm -> case parsed' of -> Success parsed -> do -> let itm = makeIvorTerm noImplicit defDo uo (UN "__main") raw parsed -> check ctxt itm -> Failure err f l -> ttfail err - -If it is an IO type, execute it, otherwise just eval it. - -> execEval :: Bool -> Ctxt IvorFun -> Context -> (Term, ViewTerm) -> IO () -> execEval True ivs ctxt (tm, (App (Name _ io) _)) -> | io == name "IO.IO" = do catch (exec ctxt tm) -> (\e -> print (e :: IOError)) -> -- putStrLn $ show (whnf ctxt tm) -> execEval runio ivs ctxt (tm, _) -> = do let res = (evalnew ctxt tm) -> -- print res -> -- putStrLn (showImp True (unIvor ivs (view res))) -> putStr (showImp False (unIvor ivs (view res))) -> putStrLn $ " : " ++ showImp False (unIvor ivs (viewType res)) - -> icheckType :: Ctxt IvorFun -> UserOps -> Context -> String -> IO () -> icheckType ivs uo ctxt tmin -> = case parseTerm tmin of -> Success tm -> -> do let itm = makeIvorTerm noImplicit defDo uo (UN "__main") ivs tm -> gtm <- ioTac $ check ctxt itm -> putStrLn $ showImp False (unIvor ivs (viewType gtm)) -> Failure err _ _ -> putStrLn err - - -> processOpts :: [Opt] -> [String] -> [Opt] -> processOpts opts [] = opts -> processOpts opts (x:xs) = processOpts (processOpt opts x) xs - -> processOpt opts "f-" = nub (NoErasure:opts) -> processOpt opts "r+" = nub (ShowRunTime:opts) - -> processOpt opts "f+" = (nub opts) \\ [NoErasure] -> processOpt opts "r-" = (nub opts) \\ [ShowRunTime] - -> processOpt opts _ = opts -- silently ignore (FIXME) - -Look up the name as a pattern definition, then as an inductive, and show -the appropriate thing, after applying the relevant transformations. - -> showdef ist ctxt [] -> = do putStrLn "Please give a name" -> return Continue -> showdef ist ctxt (n:_) -> = do case getPatternDef ctxt (name n) of -> Right (ty, pats) -> do showPDefs n (idris_context ist) (transform ctxt [] (transforms (idris_fixities ist)) (name n) pats) -> putStrLn "Compiles as:\n" -> showPats n (idris_context ist) (transform ctxt -> (idris_transforms ist) -> (transforms (idris_fixities ist)) -> (name n) pats) -> -- let Right (args, sc) = getCompiledPatternDef ctxt (name n) -> -- putStrLn "\nInternally compiled as:\n" -> -- print (args, sc) -> _ -> case getInductive ctxt (name n) of -> Right ind -> showInductive n ctxt (idris_transforms ist) -> (constructors ind) -> _ -> putStrLn $ n ++ " not defined" -> return Continue - -> showPats :: String -> Ctxt IvorFun -> Patterns -> IO () -> showPats n ivs (Patterns ps) = putStrLn $ concat (map (\x -> showp' x ++ "\n") ps) -> where showp' (PClause args _ ty) -> = n ++ " " ++ concat (map (\x -> showarg (show x)) args) ++ "= " ++ showId ty -> showarg x = if (' ' `elem` x) then "(" ++ x ++ ") " else x ++ " " -> showId res = show res -- showImp True (unIvor ivs res) - -> showPDefs :: String -> Ctxt IvorFun -> Patterns -> IO () -> showPDefs n ivs (Patterns ps) = putStrLn $ concat (map (\x -> showp' x ++ "\n") ps) -> where showp' (PClause args _ ty) -> = n ++ " " ++ concat (map (\x -> showarg (show x)) args) ++ "= " ++ showId ty -> showarg x = if (' ' `elem` x) then "(" ++ x ++ ") " else x ++ " " -> showId res = showImp False (unIvor ivs res) - -> showInductive :: String -> Context -> [Transform] -> -> [(Name, ViewTerm)] -> IO () -> showInductive n ctxt trans cons -> = do putStrLn $ n ++ " constructors:" -> putStrLn $ concat (map (\x -> " " ++ showc x ++ "\n") cons) -> where showc (n, ty) = let atys = Ivor.TT.getArgTypes ty -> args = map mkName atys -> app = apply (Name DataCon n) args in -> show (applyTransforms ctxt trans app) -> mkName (n, ty) = Name Unknown (name (showarg (useName (show n) ty))) -> useName ('_':'_':_) ty = show ty -> useName n ty = n ++ " : " ++ show ty -> showarg x = if (' ' `elem` x) then "(" ++ x ++ ")" else x - -> prims c = do c <- addPrimitive c (name "Int") -> c <- addPrimitive c (name "Char") -> c <- addPrimitive c (name "Float") -> c <- addPrimitive c (name "String") -> c <- addPrimitive c (name "Lock") -> c <- addPrimitive c (name "Handle") -> c <- addPrimitive c (name "Ptr") -> c <- addBinOp c (opFn Plus) ((+)::Int->Int->Int) "Int->Int->Int" -> c <- addBinOp c (opFn Minus) ((-)::Int->Int->Int) -> "Int->Int->Int" -> c <- addBinOp c (opFn Times) ((*)::Int->Int->Int) -> "Int->Int->Int" -> c <- addBinOp c (opFn Divide) (div::Int->Int->Int) -> "Int->Int->Int" -> c <- addBinOp c (opFn Modulo) (mod::Int->Int->Int) -> "Int->Int->Int" -> c <- addBinOp c (opFn FPlus) ((+)::Double->Double->Double) "Float->Float->Float" -> c <- addBinOp c (opFn FMinus) ((-)::Double->Double->Double) -> "Float->Float->Float" -> c <- addBinOp c (opFn FTimes) ((*)::Double->Double->Double) -> "Float->Float->Float" -> c <- addBinOp c (opFn FDivide) ((/)::Double->Double->Double) -> "Float->Float->Float" -> c <- addBinOp c (opFn Concat) ((++)::String->String->String) -> "String->String->String" -> c <- addBinOp c (opFn StringGetIndex) -> ((\str i -> str!!!(i,"stringGetIndex fail"))::String->Int->Char) -> "String->Int->Char" -> c <- addBinOp c (opFn ShL) (shl::Int->Int->Int) "Int->Int->Int" -> c <- addBinOp c (opFn ShR) (shr::Int->Int->Int) "Int->Int->Int" -> c <- addExternalFn c (opFn OpEq) 2 constEq "Int->Int->Bool" -> c <- addExternalFn c (name "__charEq") 2 constEq "Char->Char->Bool" -> c <- addExternalFn c (name "__strEq") 2 constEq "String->String->Bool" -> c <- addExternalFn c (name "__strLT") 2 constLT "String->String->Bool" -> c <- addExternalFn c (opFn OpLT) 2 intlt "Int->Int->Bool" -> c <- addExternalFn c (opFn OpLEq) 2 intle "Int->Int->Bool" -> c <- addExternalFn c (opFn OpGT) 2 intgt "Int->Int->Bool" -> c <- addExternalFn c (opFn OpGEq) 2 intge "Int->Int->Bool" - -> c <- addExternalFn c (opFn OpFEq) 2 constEq "Float->Float->Bool" -> c <- addExternalFn c (opFn OpFLT) 2 floatlt "Float->Float->Bool" -> c <- addExternalFn c (opFn OpFLEq) 2 floatle "Float->Float->Bool" -> c <- addExternalFn c (opFn OpFGT) 2 floatgt "Float->Float->Bool" -> c <- addExternalFn c (opFn OpFGEq) 2 floatge "Float->Float->Bool" - -> c <- addExternalFn c (opFn FloatToString) 1 floatToString "Float->String" -> c <- addExternalFn c (opFn ToString) 1 intToString "Int->String" -> c <- addExternalFn c (opFn ToInt) 1 stringToInt "String->Int" -> c <- addExternalFn c (opFn StringToFloat) 1 stringToFloat "String->Float" -> c <- addExternalFn c (opFn IntToChar) 1 intToChar "Int->Char" -> c <- addExternalFn c (opFn CharToInt) 1 charToInt "Char->Int" -> c <- addExternalFn c (opFn StringLength) 1 stringLen "String->Int" -> c <- addExternalFn c (opFn StringHead) 1 stringHead "String->Char" -> c <- addExternalFn c (opFn StringTail) 1 stringTail "String->String" -> c <- addExternalFn c (opFn StringCons) 2 stringCons "Char->String->String" -> c <- addExternalFn c (opFn StringRev) 1 stringRev "String->String" -> c <- addExternalFn c (opFn StringSub) 3 stringSub "String->Int->Int->String" -> c <- addExternalFn c (opFn StringFind) 2 stringFind "String->Char->Int" -> c <- addExternalFn c (name "__Prove_Anything") 3 proveAnything -> "(A:*)->(B:*)->A->B" -> c <- addExternalFn c (name "__lazy") 1 runLazy "(A:*)A->A" -> c <- addExternalFn c (name "__effect") 1 runEffect "(A:*)A->A" -> return c - -> shl :: Int -> Int -> Int -> shl x 0 = x -> shl x n = shl (x*2) (n-1) - -> shr :: Int -> Int -> Int -> shr x 0 = x -> shr x n = shr (x `div` 2) (n-1) - -> constEq :: [ViewTerm] -> Maybe ViewTerm -> constEq [Constant x, Constant y] -> = case cast x of -> Just x' -> if (x'==y) -> then Just $ Name DataCon (name "True") -> else Just $ Name DataCon (name "False") -> _ -> Nothing -> constEq _ = Nothing - -> constLT :: [ViewTerm] -> Maybe ViewTerm -> constLT [Constant x, Constant y] -> = case (cast x, cast y) :: (Maybe String, Maybe String) of -> (Just x', Just y') -> if (x' then Just $ Name DataCon (name "True") -> else Just $ Name DataCon (name "False") -> _ -> Nothing -- Just $ Name DataCon (name "False") - - constEq [_, x, y] = if (x == y) then Just $ Name DataCon (name "True") - else Just $ Name DataCon (name "False") - -> constLT _ = Nothing - -> intlt :: [ViewTerm] -> Maybe ViewTerm -> intlt [Constant x, Constant y] -> = case (cast x, cast y) of -> (Just x', Just y') -> if (x'<(y'::Int)) -> then Just $ Name DataCon (name "True") -> else Just $ Name DataCon (name "False") -> _ -> Nothing -> intlt _ = Nothing - -> intle :: [ViewTerm] -> Maybe ViewTerm -> intle [Constant x, Constant y] -> = case (cast x, cast y) of -> (Just x', Just y') -> if (x'<=(y'::Int)) -> then Just $ Name DataCon (name "True") -> else Just $ Name DataCon (name "False") -> _ -> Nothing -> intle _ = Nothing - -> intgt :: [ViewTerm] -> Maybe ViewTerm -> intgt [Constant x, Constant y] -> = case (cast x, cast y) of -> (Just x', Just y') -> if (x'>(y'::Int)) -> then Just $ Name DataCon (name "True") -> else Just $ Name DataCon (name "False") -> _ -> Nothing -> intgt _ = Nothing - -> intge :: [ViewTerm] -> Maybe ViewTerm -> intge [Constant x, Constant y] -> = case (cast x, cast y) of -> (Just x', Just y') -> if (x'>=(y'::Int)) -> then Just $ Name DataCon (name "True") -> else Just $ Name DataCon (name "False") -> _ -> Nothing -> intge _ = Nothing - -> floatlt :: [ViewTerm] -> Maybe ViewTerm -> floatlt [Constant x, Constant y] -> = case (cast x, cast y) of -> (Just x', Just y') -> if (x'<(y'::Double)) -> then Just $ Name DataCon (name "True") -> else Just $ Name DataCon (name "False") -> _ -> Nothing -> floatlt _ = Nothing - -> floatle :: [ViewTerm] -> Maybe ViewTerm -> floatle [Constant x, Constant y] -> = case (cast x, cast y) of -> (Just x', Just y') -> if (x'<=(y'::Double)) -> then Just $ Name DataCon (name "True") -> else Just $ Name DataCon (name "False") -> _ -> Nothing -> floatle _ = Nothing - -> floatgt :: [ViewTerm] -> Maybe ViewTerm -> floatgt [Constant x, Constant y] -> = case (cast x, cast y) of -> (Just x', Just y') -> if (x'>(y'::Double)) -> then Just $ Name DataCon (name "True") -> else Just $ Name DataCon (name "False") -> _ -> Nothing -> floatgt _ = Nothing - -> floatge :: [ViewTerm] -> Maybe ViewTerm -> floatge [Constant x, Constant y] -> = case (cast x, cast y) of -> (Just x', Just y') -> if (x'>=(y'::Double)) -> then Just $ Name DataCon (name "True") -> else Just $ Name DataCon (name "False") -> _ -> Nothing -> floatge _ = Nothing - -> intToString :: [ViewTerm] -> Maybe ViewTerm -> intToString [Constant x] -> = case cast x of -> (Just s) -> Just (Constant (iToS s)) -> _ -> Nothing -> where iToS :: Int -> String -> iToS x = show x -> intToString _ = Nothing - -> floatToString :: [ViewTerm] -> Maybe ViewTerm -> floatToString [Constant x] -> = case cast x of -> (Just s) -> Just (Constant (fToS s)) -> _ -> Nothing -> where fToS :: Double -> String -> fToS x = show x -> floatToString _ = Nothing - -> stringToInt :: [ViewTerm] -> Maybe ViewTerm -> stringToInt [Constant x] -> = case cast x of -> (Just s) -> Just (Constant (sToI s)) -> _ -> Nothing -> where sToI :: String -> Int -> sToI ('-':s) | all isDigit s = -(read s) -> sToI s | all isDigit s = read s -> | otherwise = 0 -> stringToInt _ = Nothing - -> stringToFloat :: [ViewTerm] -> Maybe ViewTerm -> stringToFloat [Constant x] -> = case cast x of -> (Just s) -> Just (Constant (sToF s)) -> _ -> Nothing -> where sToF :: String -> Int -> sToF ('-':s) = -(read s) -> sToF s = read s -> stringToFloat _ = Nothing - -> intToChar :: [ViewTerm] -> Maybe ViewTerm -> intToChar [Constant x] = case cast x :: Maybe Int of -> Just i -> Just (Constant (toEnum i :: Char)) -> _ -> Nothing -> intToChar _ = Nothing - -> charToInt :: [ViewTerm] -> Maybe ViewTerm -> charToInt [Constant x] = case cast x :: Maybe Char of -> Just i -> Just (Constant (fromEnum i :: Int)) -> _ -> Nothing -> charToInt _ = Nothing - -> stringLen :: [ViewTerm] -> Maybe ViewTerm -> stringLen [Constant x] = case cast x :: Maybe String of -> (Just s) -> Just (Constant (length s)) -> _ -> Nothing -> stringLen _ = Nothing - -> stringHead :: [ViewTerm] -> Maybe ViewTerm -> stringHead [Constant x] = case cast x :: Maybe String of -> (Just (s:ss)) -> Just (Constant s) -> _ -> Nothing -> stringHead _ = Nothing - -> stringTail :: [ViewTerm] -> Maybe ViewTerm -> stringTail [Constant x] = case cast x :: Maybe String of -> (Just (s:ss)) -> Just (Constant ss) -> _ -> Nothing -> stringTail _ = Nothing - -> stringCons :: [ViewTerm] -> Maybe ViewTerm -> stringCons [Constant x, Constant y] -> = case (cast x, cast y) of -> (Just s, Just ss) -> Just (Constant ((s:ss) :: String)) -> _ -> Nothing -> stringCons _ = Nothing - -> stringRev :: [ViewTerm] -> Maybe ViewTerm -> stringRev [Constant x] = case cast x :: Maybe String of -> Just s -> Just (Constant (reverse s)) -> _ -> Nothing -> stringRev _ = Nothing - -> stringSub :: [ViewTerm] -> Maybe ViewTerm -> stringSub [Constant x, Constant start, Constant len] -> = case (cast x, cast start, cast len) :: -> (Maybe String, Maybe Int, Maybe Int) of -> (Just str, Just st, Just l) -> -> Just (Constant (take l (drop st str) :: String)) -> _ -> Nothing -> stringSub _ = Nothing - -> stringFind :: [ViewTerm] -> Maybe ViewTerm -> stringFind [Constant x, Constant y] -> = case (cast x, cast y) :: (Maybe String, Maybe Char) of -> (Just s, Just c) -> -> case findIndex (==c) s of -> Just v -> Just (Constant v) -> Nothing -> Just (Constant ((-1) :: Int)) -> _ -> Nothing -> stringFind _ = Nothing - -> proveAnything :: [ViewTerm] -> Maybe ViewTerm -> proveAnything [_,_,x] = Just x -> proveAnything _ = Nothing - -> runLazy :: [ViewTerm] -> Maybe ViewTerm -> runLazy [_,x] = Just x -> runLazy _ = Nothing - -> runEffect :: [ViewTerm] -> Maybe ViewTerm -> runEffect [_,x] = Just x -> runEffect _ = Nothing diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,39 @@ +import Distribution.Simple +import Distribution.Simple.InstallDirs as I +import Distribution.Simple.LocalBuildInfo as L +import Distribution.PackageDescription + +import System.Exit +import System.Process + +-- After Idris is built, we need to check and install the prelude and other libs + +system' cmd = do + exit <- system cmd + case exit of + ExitSuccess -> return () + ExitFailure _ -> exitWith exit + +postCleanLib args flags desc _ + = system' "make -C lib clean" + +addPrefix pfx var c = "export " ++ var ++ "=" ++ show pfx ++ "/" ++ c ++ ":$" ++ var + +postInstLib args flags desc local + = do let pkg = localPkgDescr local + let penv = packageTemplateEnv (package pkg) + let cenv = compilerTemplateEnv (compilerId (compiler local)) + let dirs_pkg = substituteInstallDirTemplates penv (installDirTemplates local) + let dirs = substituteInstallDirTemplates cenv dirs_pkg + let datad = datadir dirs + let datasubd = datasubdir dirs + let bind = fromPathTemplate (bindir dirs) + let idir = fromPathTemplate (datadir dirs) ++ "/" ++ + fromPathTemplate (datasubdir dirs) + putStrLn $ "Installing libraries in " ++ idir + system' $ "make -C lib install TARGET=" ++ idir ++ " BINDIR=" ++ bind + +main = defaultMainWithHooks (simpleUserHooks { postInst = postInstLib, + postClean = postCleanLib }) + + diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,38 +0,0 @@ -> import Distribution.Simple -> import Distribution.Simple.InstallDirs -> import Distribution.Simple.LocalBuildInfo -> import Distribution.PackageDescription - -> import System - -After Idris is built, we need to check and install the .idr library files, -and the C support they need. - -FIXME: This is probably all done the wrong way, I don't really understand -Cabal properly... This is all stolen from the Epic build system. - -> buildLib args flags desc local -> = do exit <- system "make -C lib" -> return () - -This is a hack. I don't know how to tell cabal that a data file needs -installing but shouldn't be in the distribution. And it won't make the -distribution if it's not there, so instead I just delete -the file after configure. - -> postConfLib args flags desc local -> = do exit <- system "make -C lib clean" -> return () - -> addPrefix pfx var c = "export " ++ var ++ "=" ++ show pfx ++ "/" ++ c ++ ":$" ++ var - -> postInstLib args flags desc local -> = do let pfx = prefix (installDirTemplates local) -> exit <- system $ "make -C lib install PREFIX=" ++ show pfx -> return () - -> main = defaultMainWithHooks (simpleUserHooks { postBuild = buildLib, -> postConf = postConfLib, -> postInst = postInstLib }) - - diff --git a/dist/build/Idris/Parser.hs b/dist/build/Idris/Parser.hs deleted file mode 100644 --- a/dist/build/Idris/Parser.hs +++ /dev/null @@ -1,3973 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -{-# OPTIONS -fglasgow-exts -cpp #-} --- -*-Haskell-*- -{-# OPTIONS_GHC -fglasgow-exts #-} - -module Idris.Parser where - -import Data.Char -import Ivor.TT -import System.IO.Unsafe -import List -import Control.Monad - -import Idris.AbsSyntax -import Idris.Lexer -import Idris.Lib - -import Debug.Trace -import qualified Data.Array as Happy_Data_Array -import qualified GHC.Exts as Happy_GHC_Exts - --- parser produced by Happy Version 1.18.5 - -newtype HappyAbsSyn t74 = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn6 :: ([ParseDecl]) -> (HappyAbsSyn t74) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn t74) -> ([ParseDecl]) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (ParseDecl) -> (HappyAbsSyn t74) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn t74) -> (ParseDecl) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (Decl) -> (HappyAbsSyn t74) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn t74) -> (Decl) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (ParseDecl) -> (HappyAbsSyn t74) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn t74) -> (ParseDecl) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: (CGFlag) -> (HappyAbsSyn t74) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn t74) -> (CGFlag) -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (Bool) -> (HappyAbsSyn t74) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn t74) -> (Bool) -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: ([RawTerm]) -> (HappyAbsSyn t74) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn t74) -> ([RawTerm]) -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: ([ParseDecl]) -> (HappyAbsSyn t74) -happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn t74) -> ([ParseDecl]) -happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: ([CGFlag]) -> (HappyAbsSyn t74) -happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn t74) -> ([CGFlag]) -happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: ([CGFlag]) -> (HappyAbsSyn t74) -happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn t74) -> ([CGFlag]) -happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: ([CGFlag]) -> (HappyAbsSyn t74) -happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn t74) -> ([CGFlag]) -happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyIn18 :: ([Decl]) -> (HappyAbsSyn t74) -happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn t74) -> ([Decl]) -happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut18 #-} -happyIn19 :: ([String]) -> (HappyAbsSyn t74) -happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn t74) -> ([String]) -happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut19 #-} -happyIn20 :: (String) -> (HappyAbsSyn t74) -happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn t74) -> (String) -happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut20 #-} -happyIn21 :: (Fixity) -> (HappyAbsSyn t74) -happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn t74) -> (Fixity) -happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut21 #-} -happyIn22 :: (Decl) -> (HappyAbsSyn t74) -happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn t74) -> (Decl) -happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut22 #-} -happyIn23 :: ([(Id,String)]) -> (HappyAbsSyn t74) -happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn t74) -> ([(Id,String)]) -happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut23 #-} -happyIn24 :: ((Id, [(RawTerm, Maybe Id)])) -> (HappyAbsSyn t74) -happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn t74) -> ((Id, [(RawTerm, Maybe Id)])) -happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut24 #-} -happyIn25 :: ([(RawTerm,Maybe Id)]) -> (HappyAbsSyn t74) -happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn t74) -> ([(RawTerm,Maybe Id)]) -happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut25 #-} -happyIn26 :: (Datatype) -> (HappyAbsSyn t74) -happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn t74) -> (Datatype) -happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut26 #-} -happyIn27 :: (Bool) -> (HappyAbsSyn t74) -happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn t74) -> (Bool) -happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut27 #-} -happyIn28 :: (Either RawTerm ((RawTerm, [(Id, RawTerm)]), [ConParse])) -> (HappyAbsSyn t74) -happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn t74) -> (Either RawTerm ((RawTerm, [(Id, RawTerm)]), [ConParse])) -happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut28 #-} -happyIn29 :: ([TyOpt]) -> (HappyAbsSyn t74) -happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn t74) -> ([TyOpt]) -happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut29 #-} -happyIn30 :: ([TyOpt]) -> (HappyAbsSyn t74) -happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn t74) -> ([TyOpt]) -happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut30 #-} -happyIn31 :: (TyOpt) -> (HappyAbsSyn t74) -happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn t74) -> (TyOpt) -happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut31 #-} -happyIn32 :: (Id) -> (HappyAbsSyn t74) -happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn t74) -> (Id) -happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut32 #-} -happyIn33 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut33 #-} -happyIn34 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut34 #-} -happyIn35 :: ([(Id, RawTerm)]) -> (HappyAbsSyn t74) -happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn t74) -> ([(Id, RawTerm)]) -happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut35 #-} -happyIn36 :: ([(Id, RawTerm)]) -> (HappyAbsSyn t74) -happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn t74) -> ([(Id, RawTerm)]) -happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut36 #-} -happyIn37 :: ([(Id, RawTerm)]) -> (HappyAbsSyn t74) -happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn t74) -> ([(Id, RawTerm)]) -happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut37 #-} -happyIn38 :: ([Id]) -> (HappyAbsSyn t74) -happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn t74) -> ([Id]) -happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut38 #-} -happyIn39 :: ([(Id, Int)]) -> (HappyAbsSyn t74) -happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn t74) -> ([(Id, Int)]) -happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut39 #-} -happyIn40 :: ([Id]) -> (HappyAbsSyn t74) -happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn t74) -> ([Id]) -happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut40 #-} -happyIn41 :: ([Id]) -> (HappyAbsSyn t74) -happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn t74) -> ([Id]) -happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut41 #-} -happyIn42 :: ([(Id, RawTerm, RawTerm)]) -> (HappyAbsSyn t74) -happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn t74) -> ([(Id, RawTerm, RawTerm)]) -happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut42 #-} -happyIn43 :: ((Id, RawTerm)) -> (HappyAbsSyn t74) -happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn t74) -> ((Id, RawTerm)) -happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut43 #-} -happyIn44 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut44 #-} -happyIn45 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut45 #-} -happyIn46 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut46 #-} -happyIn47 :: (String) -> (HappyAbsSyn t74) -happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn t74) -> (String) -happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut47 #-} -happyIn48 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut48 #-} -happyIn49 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut49 #-} -happyIn50 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut50 #-} -happyIn51 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn51 #-} -happyOut51 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut51 #-} -happyIn52 :: (ArgOpt) -> (HappyAbsSyn t74) -happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn52 #-} -happyOut52 :: (HappyAbsSyn t74) -> (ArgOpt) -happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut52 #-} -happyIn53 :: ([ArgOpt]) -> (HappyAbsSyn t74) -happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn53 #-} -happyOut53 :: (HappyAbsSyn t74) -> ([ArgOpt]) -happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut53 #-} -happyIn54 :: ([ArgOpt]) -> (HappyAbsSyn t74) -happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn54 #-} -happyOut54 :: (HappyAbsSyn t74) -> ([ArgOpt]) -happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut54 #-} -happyIn55 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn55 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn55 #-} -happyOut55 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut55 #-} -happyIn56 :: ([RawTerm]) -> (HappyAbsSyn t74) -happyIn56 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn56 #-} -happyOut56 :: (HappyAbsSyn t74) -> ([RawTerm]) -happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut56 #-} -happyIn57 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn57 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn57 #-} -happyOut57 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut57 #-} -happyIn58 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn58 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn58 #-} -happyOut58 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut58 #-} -happyIn59 :: ([RawTerm]) -> (HappyAbsSyn t74) -happyIn59 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn59 #-} -happyOut59 :: (HappyAbsSyn t74) -> ([RawTerm]) -happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut59 #-} -happyIn60 :: ([RawTerm]) -> (HappyAbsSyn t74) -happyIn60 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn60 #-} -happyOut60 :: (HappyAbsSyn t74) -> ([RawTerm]) -happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut60 #-} -happyIn61 :: ([Do]) -> (HappyAbsSyn t74) -happyIn61 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn61 #-} -happyOut61 :: (HappyAbsSyn t74) -> ([Do]) -happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut61 #-} -happyIn62 :: ([Do]) -> (HappyAbsSyn t74) -happyIn62 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn62 #-} -happyOut62 :: (HappyAbsSyn t74) -> ([Do]) -happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut62 #-} -happyIn63 :: (Do) -> (HappyAbsSyn t74) -happyIn63 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn63 #-} -happyOut63 :: (HappyAbsSyn t74) -> (Do) -happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut63 #-} -happyIn64 :: (Constant) -> (HappyAbsSyn t74) -happyIn64 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn64 #-} -happyOut64 :: (HappyAbsSyn t74) -> (Constant) -happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut64 #-} -happyIn65 :: ([RawTerm]) -> (HappyAbsSyn t74) -happyIn65 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn65 #-} -happyOut65 :: (HappyAbsSyn t74) -> ([RawTerm]) -happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut65 #-} -happyIn66 :: ((RawTerm, [(Id, RawTerm)])) -> (HappyAbsSyn t74) -happyIn66 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn66 #-} -happyOut66 :: (HappyAbsSyn t74) -> ((RawTerm, [(Id, RawTerm)])) -happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut66 #-} -happyIn67 :: ([(Id, RawTerm)]) -> (HappyAbsSyn t74) -happyIn67 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn67 #-} -happyOut67 :: (HappyAbsSyn t74) -> ([(Id, RawTerm)]) -happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut67 #-} -happyIn68 :: ((Id,Id)) -> (HappyAbsSyn t74) -happyIn68 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn68 #-} -happyOut68 :: (HappyAbsSyn t74) -> ((Id,Id)) -happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut68 #-} -happyIn69 :: ((Id,Id)) -> (HappyAbsSyn t74) -happyIn69 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn69 #-} -happyOut69 :: (HappyAbsSyn t74) -> ((Id,Id)) -happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut69 #-} -happyIn70 :: ([(Id, RawTerm)]) -> (HappyAbsSyn t74) -happyIn70 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn70 #-} -happyOut70 :: (HappyAbsSyn t74) -> ([(Id, RawTerm)]) -happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut70 #-} -happyIn71 :: (Id) -> (HappyAbsSyn t74) -happyIn71 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn71 #-} -happyOut71 :: (HappyAbsSyn t74) -> (Id) -happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut71 #-} -happyIn72 :: ([(Id, RawTerm)]) -> (HappyAbsSyn t74) -happyIn72 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn72 #-} -happyOut72 :: (HappyAbsSyn t74) -> ([(Id, RawTerm)]) -happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut72 #-} -happyIn73 :: ([Id]) -> (HappyAbsSyn t74) -happyIn73 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn73 #-} -happyOut73 :: (HappyAbsSyn t74) -> ([Id]) -happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut73 #-} -happyIn74 :: t74 -> (HappyAbsSyn t74) -happyIn74 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn74 #-} -happyOut74 :: (HappyAbsSyn t74) -> t74 -happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut74 #-} -happyIn75 :: ([ConParse]) -> (HappyAbsSyn t74) -happyIn75 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn75 #-} -happyOut75 :: (HappyAbsSyn t74) -> ([ConParse]) -happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut75 #-} -happyIn76 :: (ConParse) -> (HappyAbsSyn t74) -happyIn76 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn76 #-} -happyOut76 :: (HappyAbsSyn t74) -> (ConParse) -happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut76 #-} -happyIn77 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn77 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn77 #-} -happyOut77 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut77 #-} -happyIn78 :: (ITactic) -> (HappyAbsSyn t74) -happyIn78 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn78 #-} -happyOut78 :: (HappyAbsSyn t74) -> (ITactic) -happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut78 #-} -happyIn79 :: ([ITactic]) -> (HappyAbsSyn t74) -happyIn79 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn79 #-} -happyOut79 :: (HappyAbsSyn t74) -> ([ITactic]) -happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut79 #-} -happyIn80 :: ([ITactic]) -> (HappyAbsSyn t74) -happyIn80 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn80 #-} -happyOut80 :: (HappyAbsSyn t74) -> ([ITactic]) -happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut80 #-} -happyIn81 :: ([ITactic]) -> (HappyAbsSyn t74) -happyIn81 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn81 #-} -happyOut81 :: (HappyAbsSyn t74) -> ([ITactic]) -happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut81 #-} -happyIn82 :: (LineNumber) -> (HappyAbsSyn t74) -happyIn82 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn82 #-} -happyOut82 :: (HappyAbsSyn t74) -> (LineNumber) -happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut82 #-} -happyIn83 :: (String) -> (HappyAbsSyn t74) -happyIn83 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn83 #-} -happyOut83 :: (HappyAbsSyn t74) -> (String) -happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut83 #-} -happyIn84 :: (Fixities) -> (HappyAbsSyn t74) -happyIn84 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn84 #-} -happyOut84 :: (HappyAbsSyn t74) -> (Fixities) -happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut84 #-} -happyInTok :: (Token) -> (HappyAbsSyn t74) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn t74) -> (Token) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x1d\x00\x5e\x05\x18\x02\x00\x00\x49\x04\x5e\x05\x37\x01\x37\x01\x5e\x05\x00\x00\x48\x03\xef\x02\x00\x00\x37\x01\x00\x00\x5e\x05\x5e\x05\x00\x00\x00\x00\x5e\x05\x5e\x05\x5e\x05\x5e\x05\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x01\x91\x09\x3d\x02\xc3\x01\x5e\x05\x5e\x05\xae\x08\x5e\x05\x00\x00\x37\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x05\x00\x00\x00\x00\x00\x00\xfc\x00\x00\x00\x5e\x05\x02\x01\x48\x04\x01\x00\x00\x00\x00\x00\x01\x00\xbc\x04\x00\x00\xa2\x04\x00\x00\x87\x04\xe2\x01\xab\x04\xa6\x04\xa5\x04\xa4\x04\x97\x04\x08\x0a\x75\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x04\x88\x04\x84\x04\x02\x01\x02\x01\x02\x01\x8e\x04\x54\x04\x7f\x04\x8f\x04\x5e\x05\x8b\x04\x8a\x04\x00\x00\x00\x00\xbd\x02\x00\x00\x02\x01\x72\x04\x75\x04\x00\x00\x02\x01\x00\x00\x02\x01\x02\x01\x02\x01\x70\x04\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x02\x00\x00\x00\x00\x00\x96\x02\x00\x00\x00\x00\x00\x00\x63\x00\x63\x00\x63\x00\x63\x00\x63\x00\x00\x00\x69\x08\x74\x04\x50\x01\x91\x09\x68\x04\x02\x01\xdc\x01\x5f\x00\x08\x0a\x75\x01\x00\x00\x00\x00\x6f\x04\x16\x04\x0e\x03\x00\x00\x6d\x04\x05\x05\x00\x00\x00\x00\x6c\x04\x00\x00\x6c\x04\x00\x00\x7a\x04\x6f\x03\x00\x00\x18\x02\x18\x02\xb8\x01\x1a\x04\xac\x04\x65\x04\xac\x04\xac\x04\x63\x04\x61\x04\xac\x04\xac\x04\x26\x0a\x62\x04\x59\x04\x1e\x00\x00\x00\x47\x04\xac\x04\x56\x09\x02\x01\x5e\x04\x37\x04\x00\x00\xae\x08\x51\x04\x00\x00\xac\x04\x45\x04\xac\x04\xac\x04\xac\x04\xac\x04\xac\x04\x00\x00\xa6\x01\x91\x01\x7c\x01\x67\x01\x52\x01\x3d\x01\x00\x00\x28\x01\xac\x04\x13\x01\xac\x04\xfe\x00\x00\x00\x3a\x04\x00\x00\xe9\x00\x02\x01\xc7\x00\x65\x00\x00\x00\x5a\x04\x5a\x04\x5a\x04\x5a\x04\x5a\x04\x00\x00\xac\x04\x5a\x04\xae\x08\x00\x00\x00\x00\x00\x00\xac\x04\x2f\x04\xcc\x09\x46\x04\x3e\x04\x28\x04\xa5\x01\x39\x04\x8b\x00\x36\x04\x53\x09\x02\x01\xcc\x09\xcc\x09\xcc\x09\x00\x00\x32\x04\xcc\x09\x31\x04\x00\x00\xd8\x05\x00\x00\xd8\x05\x00\x00\xd8\x05\x00\x00\xd8\x05\x00\x00\xac\x04\x00\x00\xac\x04\xac\x04\xac\x04\xac\x04\xac\x04\x2b\x04\x38\x04\x2d\x04\x24\x04\xac\x04\x00\x00\x00\x00\xac\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\xd8\x05\x23\x04\x53\x04\x02\x01\xf6\x03\x00\x00\xfa\x03\xfa\x03\x08\x04\x1b\x04\x04\x04\x19\x04\xfa\x03\xfa\x03\xfa\x03\xc6\x03\x0c\x04\xfd\x03\x00\x00\x00\x00\xd3\x05\x18\x02\x15\x04\x69\x08\xfa\x03\x00\x00\x00\x00\x0b\x04\x06\x04\x05\x04\x03\x04\x01\x04\x00\x00\x00\x00\x18\x04\x02\x04\x00\x00\x00\x00\xfa\x03\xfa\x03\xfa\x03\x00\x00\x07\x04\xfe\x03\xe6\x03\xfc\x03\x02\x01\xeb\x03\x00\x00\x01\x00\x02\x01\xf4\x03\xe5\x03\x00\x00\xfa\x03\x7e\x05\xfb\x03\x00\x04\x00\x00\xd6\x03\x00\x00\xec\x03\xfa\x03\x00\x00\x00\x00\x02\x01\x00\x00\x91\x09\x25\x05\xcc\x04\x7c\x05\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x05\x00\x00\xe1\x03\xd5\x03\x00\x00\x02\x01\x02\x01\xd1\x03\x91\x09\x00\x00\x00\x00\xdc\x01\x00\x00\x00\x00\xca\x04\x9c\x04\x91\x03\x00\x00\x75\x01\x00\x00\xfa\x03\xaa\x00\xb4\x02\xfa\x03\xda\x03\x00\x00\x00\x00\x00\x00\xb8\x03\x1a\x09\x00\x00\xf3\x08\x16\x03\x00\x00\xc8\x03\xd2\x03\x00\x00\x00\x00\x18\x02\xcc\x09\x00\x00\x67\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x03\x00\x00\xcd\x03\x00\x00\xae\x08\x00\x00\x1e\x00\xa3\x03\xa2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x09\xcc\x09\xbb\x03\x91\x09\x02\x01\x95\x03\x91\x09\x1e\x00\x02\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x08\xf3\x08\xf3\x08\xf3\x08\xf3\x08\xf3\x08\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x09\x00\x00\xd4\x00\x8c\x03\xd0\x01\x0a\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x91\x09\x00\x00\x00\x00\x24\x08\x00\x00\xdf\x07\x00\x00\x9a\x07\x00\x00\x55\x07\xbd\x03\xb7\x03\xb6\x03\xb4\x03\xb3\x03\x55\x00\x00\x00\x00\x00\xfa\x03\x00\x00\x00\x00\xfa\x03\x10\x07\xa0\x03\xd8\x05\xfa\x03\xde\x01\x00\x00\x46\x00\xa9\x03\xa7\x03\x00\x00\x00\x00\x00\x00\xf8\xff\x00\x00\xcb\x06\xab\x03\xa6\x03\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x01\x00\x00\x86\x06\x00\x00\x46\x00\x00\x00\x99\x03\x86\x03\x9a\x03\x38\x03\x00\x00\x02\x01\x76\x03\x00\x00\x00\x00\x02\x01\x8d\x03\x00\x00\x00\x00\x02\x01\x02\x01\x46\x00\x7d\x03\x00\x00\x00\x00\x00\x00\x83\x03\xd9\x01\x8b\x03\x00\x00\x00\x00\x00\x00\x7b\x03\x00\x00\x00\x00\x02\x01\x00\x00\xae\x08\x00\x00\x00\x00\x91\x09\x00\x00\x3e\x03\x00\x00\x00\x00\x00\x00\x02\x01\x00\x00\x74\x03\x02\x01\x82\x03\x00\x00\xfa\x03\x00\x00\xd8\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x03\x61\x03\x00\x00\x00\x00\xcc\x09\x49\x03\x49\x03\x00\x00\xd0\x01\x62\x03\x00\x00\x00\x00\x00\x00\xde\x01\x41\x06\x00\x00\x00\x00\x00\x00\x00\x00\x60\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x03\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\x5e\x03\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x03\x00\x00\xfc\x05\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x05\x5b\x03\x00\x00\x00\x00\x00\x00\x3c\x03\x02\x01\x00\x00\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\xf6\x0a\x55\x10\x24\x03\x00\x00\x00\x00\x3f\x10\x96\x01\x51\x03\x29\x10\x00\x00\x13\x10\xfd\x0f\x00\x00\x47\x03\x00\x00\xe7\x0f\xd1\x0f\x00\x00\x00\x00\xbb\x0f\xa5\x0f\x8f\x0f\x79\x0f\x00\x00\x00\x00\x00\x00\x1a\x03\x39\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\xb7\x0c\x77\x0b\x10\x03\x63\x0f\x4d\x0f\x9e\x10\x37\x0f\x00\x00\x3f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x0f\x00\x00\x07\x03\x06\x03\x00\x00\x05\x03\x0b\x0f\x59\x01\x00\x00\xdb\x0a\x00\x00\x00\x00\xd4\x0a\x00\x00\x00\x00\x44\x03\x00\x00\x2e\x03\x8d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x31\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x03\x1c\x03\x14\x03\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x39\x01\xe7\x02\x08\x01\x00\x00\x00\x00\xe5\x02\x68\x01\x00\x00\x41\x01\x13\x03\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x03\xdd\x02\x29\x01\x00\x00\xd2\x02\x7f\x0b\x00\x00\xd1\x02\xd0\x02\xbe\x0a\x88\x0a\x72\x0a\x6b\x0a\x50\x0a\x00\x00\xf9\x06\x00\x00\x00\x00\x8b\x0c\x00\x00\x02\x03\xea\x01\x15\x03\x94\x00\xe0\x01\x00\x00\x00\x00\xec\x02\x00\x00\x24\x01\xc9\x02\xdf\x02\xc7\x0b\xc7\x02\xbf\x02\x21\x01\xc0\x02\x14\x01\x00\x00\x0f\x01\x0f\x01\xbc\x02\xc9\x01\xc5\x01\x2a\x00\xdf\xff\xdf\x0e\x00\x00\xc9\x0e\xb3\x0e\x00\x00\x00\x00\x4f\x0b\x4a\x0b\x0c\x01\xdb\x02\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x0e\xa7\x02\xb4\x01\xda\x02\x00\x00\xb6\x02\x8d\x10\x00\x00\xb5\x02\x87\x0e\xb3\x02\x71\x0e\x5b\x0e\x45\x0e\x2f\x0e\x19\x0e\xae\x02\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x00\x00\x0a\x01\x03\x0e\x0a\x01\xed\x0d\x0a\x01\x00\x00\x00\x00\x00\x00\x0a\x01\x81\x01\x0a\x01\x0a\x01\x00\x00\x04\x01\xff\x00\xef\x00\xe5\x00\xd6\x00\xad\x02\xd7\x0d\xd2\x00\x80\x10\xa4\x02\x9d\x02\x00\x00\xc1\x0d\x00\x00\x26\x07\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x33\x01\x9c\x06\x57\x06\x99\x05\x00\x00\x00\x00\x69\x04\x00\x00\x9a\x02\xcb\x00\x97\x02\xc2\x00\x92\x02\xbb\x00\x90\x02\xb0\x00\x8f\x02\x2b\x0b\x00\x00\x26\x0b\xab\x0d\x95\x0d\x88\x09\x07\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x09\x0c\x00\x00\x88\x02\x7f\x0d\x87\x02\x86\x02\x7b\x02\x00\x00\x00\x00\xfc\xff\x99\x00\x00\x00\xb1\x0b\x3e\x01\x00\x00\x00\x00\x69\x0d\x53\x0d\x00\x00\x00\x00\x00\x00\xbe\x02\x3d\x0d\x27\x0d\x11\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\xc1\x01\x00\x00\xb4\x06\xfb\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x02\x71\x02\x79\x00\x00\x00\x70\x02\x68\x02\xe5\x0c\xcf\x0c\xb9\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x64\x02\xd6\x09\x95\x02\x00\x00\x00\x00\x61\x02\xa3\x0c\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x0c\x00\x00\x00\x00\x91\x02\x00\x00\x5f\x0c\x79\x00\x79\x00\x79\x00\x00\x00\x00\x00\x5c\x02\x00\x00\xf3\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x5a\x02\x99\x02\x00\x00\x54\x02\x4f\x00\xef\xff\x00\x00\x33\x0c\x53\x02\x17\x02\xa4\x01\x00\x00\x00\x00\x79\x00\x79\x00\x79\x00\x00\x00\x35\x01\x00\x00\x77\x0c\x79\x00\x79\x00\x61\x0c\x02\x02\x00\x00\x00\x00\x47\x02\x00\x00\x78\x10\x00\x00\x78\x10\x79\x00\x46\x02\x79\x00\x00\x00\x00\x00\x00\x00\xbe\x01\x44\x04\x45\x02\x79\x00\x00\x00\x41\x02\x22\x02\x21\x02\x20\x02\x1e\x02\x1c\x02\x1b\x02\x00\x00\x1a\x02\x00\x00\x12\x02\x6b\x10\x10\x02\x00\x00\x00\x00\x00\x00\x0f\x02\x0e\x02\x00\x00\x00\x00\x0c\x02\x00\x00\xb2\x03\xc2\x01\x07\x02\x07\x0c\x4e\x01\x00\x00\xdb\x0b\x00\x00\x2e\x00\x79\x00\x0a\x02\x08\x02\x00\x00\xfe\x01\x79\x00\x00\x00\xfd\x01\xfc\x01\xfb\x01\xf0\x01\xec\x01\x00\x00\x5a\x10\x5a\x10\x5a\x10\x5a\x10\x5a\x10\x5a\x10\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x02\x00\x00\x00\x00\x00\x00\xaa\x01\x00\x00\x00\x00\xdb\x01\xeb\x01\xdf\x01\xd1\x01\xf0\x09\xc6\x01\x00\x00\x50\x10\x00\x00\x50\x10\x00\x00\x50\x10\x00\x00\x50\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x0b\x00\x00\x95\x01\x4b\x0c\x50\x10\x00\x00\x78\x00\x35\x0c\x6b\x00\x00\x00\xa0\x02\xe7\x01\x00\x00\x00\x00\xb3\x01\xab\x01\x9e\x01\x8c\x01\xf6\x01\x00\x00\x00\x00\x00\x00\x89\x01\x00\x00\x6a\x01\x23\x01\x85\x01\x2a\x06\x7e\x01\x4f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x93\x01\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x71\x00\x73\x01\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x01\x00\x00\xed\xff\x00\x00\x97\x08\x00\x00\x00\x00\x02\x09\x4a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x01\xc0\x00\x00\x00\xd5\x00\x5c\x00\x9c\x00\x1f\x0c\x00\x00\x47\x00\x95\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x01\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\x7f\x00\x00\x00\x4a\x00\x21\x00\xdc\x08\x38\x00\x00\x00\x20\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\xd0\xff\xdc\x08\x9b\x0b\xcb\xff\xdc\x08\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x08\x00\x00\x00\x00\xc6\xff\x00\x00\x00\x00\x1d\x01\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x21\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\xff\x00\x00\x00\x00\x0a\xff\x00\x00\x00\x00\x05\xff\x00\x00\x03\xff\x00\x00\x00\x00\x00\xff\xff\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xfe\xf9\xfe\xf8\xfe\xf0\xfe\xf0\xfe\x9b\xff\x80\xff\x45\xff\x46\xff\xa2\xff\x44\xff\x49\xff\xf0\xfe\xab\xff\x29\xff\x2b\xff\x27\xff\x2a\xff\x28\xff\x52\xff\x00\x00\x00\x00\x00\x00\xf0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x4a\xff\x00\x00\x31\xff\x30\xff\x2f\xff\x32\xff\x2d\xff\x2e\xff\x2c\xff\x34\xff\x33\xff\x00\x00\x4d\xff\xf0\xfe\xf0\xfe\x00\x00\xf0\xfe\x00\x00\x00\x00\x00\x00\x21\xff\xef\xff\xf8\xff\x21\xff\x00\x00\xf6\xff\xda\xff\xf7\xff\xb1\xff\xbb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\xff\xb5\xff\xc0\xff\xc2\xff\xc1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xff\xec\xff\xf0\xfe\xf0\xfe\x00\x00\x00\x00\x00\x00\xf0\xfe\x8c\xff\x1c\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xff\xc5\xff\xc4\xff\xc3\xff\x00\x00\xf0\xfe\xf0\xfe\xd8\xff\xf0\xfe\x00\x00\xa5\xff\xf0\xfe\xf0\xfe\x21\xff\x21\xff\x21\xff\x21\xff\x21\xff\xbc\xff\xbb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xff\xfb\xff\x70\xff\x00\x00\xf0\xfe\xf1\xfe\x70\xff\x00\x00\xf1\xfe\xf1\xfe\xf0\xfe\xf0\xfe\xf0\xfe\x53\xff\xf0\xfe\xf0\xfe\xf1\xfe\x00\x00\x00\x00\xf0\xfe\xf0\xfe\x00\x00\x00\x00\xc6\xff\xc5\xff\x72\xff\x71\xff\xf0\xfe\xf0\xfe\xf0\xfe\x6e\xff\x00\x00\x6b\xff\x60\xff\x8e\xff\x00\x00\x00\x00\x00\x00\x70\xff\x00\x00\xf1\xfe\x00\x00\x00\x00\xf1\xfe\x00\x00\xf0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\x04\xff\xf0\xfe\x00\x00\xf0\xfe\x00\x00\xf0\xfe\x0d\xff\x94\xff\x0f\xff\xf0\xfe\x00\x00\xf0\xfe\xf0\xfe\x56\xff\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf1\xfe\x00\x00\xf0\xfe\x00\x00\xf0\xfe\xf0\xfe\x4e\xff\x00\x00\x99\xff\x00\x00\x00\x00\x00\x00\x96\xff\xf0\xfe\x00\x00\x00\x00\x00\x00\xf0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xa1\xff\x00\x00\x00\x00\x00\x00\xf1\xfe\xf0\xfe\xf1\xfe\xf0\xfe\xf1\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\x54\xff\xf0\xfe\x72\xff\x71\xff\xf0\xfe\xf0\xfe\x00\x00\xf5\xfe\x00\x00\x00\x00\x3e\xff\x48\xff\xf0\xfe\x00\x00\xf1\xfe\xf1\xfe\xf1\xfe\x4c\xff\x4b\xff\xf0\xfe\xf0\xfe\x00\x00\x38\xff\x00\x00\x00\x00\x55\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc8\xff\xda\xff\x00\x00\x00\x00\x00\x00\xdd\xff\x00\x00\xaf\xff\xad\xff\xac\xff\x00\x00\x00\x00\x00\x00\xbb\xff\x00\x00\xe8\xff\xba\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\xfe\xf1\xfe\xf0\xfe\x00\x00\xf1\xfe\xf1\xfe\x00\x00\x00\x00\x00\x00\xaa\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8c\xff\x00\x00\xf1\xfe\x21\xff\x00\x00\x00\x00\x00\x00\xf1\xfe\x00\x00\xf0\xfe\x00\x00\x00\x00\xbf\xff\x00\x00\xf9\xff\x00\x00\x00\x00\x8b\xff\x1d\xff\x00\x00\x20\xff\x00\x00\xf0\xfe\xf0\xfe\xf0\xfe\xa7\xff\xa6\xff\xf0\xfe\xd7\xff\x00\x00\xa4\xff\xa3\xff\xf0\xff\xf1\xff\xf2\xff\xf3\xff\xf4\xff\xf0\xfe\xf0\xfe\xd2\xff\x00\x00\xf0\xfe\x19\xff\x15\xff\x00\x00\x00\x00\xf0\xfe\xf0\xfe\x00\x00\xb0\xff\xdc\xff\xf0\xfe\xf0\xfe\xf0\xfe\xdb\xff\x00\x00\xc9\xff\x00\x00\xf0\xfe\xf0\xfe\x00\x00\x70\xff\x39\xff\x3b\xff\xf1\xfe\x00\x00\x9e\xff\x4f\xff\x86\xff\xf0\xfe\xf1\xfe\xf0\xfe\x00\x00\x51\xff\x50\xff\xf6\xfe\x00\x00\xf1\xfe\xf0\xfe\x3f\xff\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\x00\x00\xf1\xfe\x00\x00\xf1\xfe\x00\x00\xf0\xfe\x6d\xff\x00\x00\x6a\xff\xf0\xfe\xf0\xfe\x8d\xff\x64\xff\xf0\xfe\x67\xff\x00\x00\x00\x00\x5c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xff\x00\x00\xf0\xfe\xf1\xfe\xf1\xfe\xa0\xff\xf1\xfe\xf0\xfe\x88\xff\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\x93\xff\x81\xff\x84\xff\x82\xff\x83\xff\x85\xff\x7e\xff\x9f\xff\x7f\xff\x98\xff\x95\xff\x00\x00\x97\xff\x6f\xff\x00\x00\x00\x00\x58\xff\x57\xff\xf0\xfe\xf1\xfe\xf1\xfe\xf1\xfe\x00\x00\xf1\xfe\xa9\xff\x00\x00\x76\xff\x00\x00\x75\xff\x00\x00\x47\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xfe\x43\xff\x3e\xff\x41\xff\xf0\xfe\x00\x00\x00\x00\x00\x00\xf0\xfe\x00\x00\xf0\xfe\xc7\xff\x00\x00\xd2\xff\x00\x00\xae\xff\xf1\xfe\xf1\xfe\x21\xff\xf0\xfe\x26\xff\x00\x00\x14\xff\x18\xff\xf1\xfe\xf7\xfe\xf0\xfe\xd1\xff\xf1\xfe\xbb\xff\xf1\xfe\x00\x00\xe4\xff\x00\x00\x1b\xff\x00\x00\xf0\xfe\xed\xff\x00\x00\xbe\xff\xf5\xff\xea\xff\x00\x00\x00\x00\xee\xff\x1e\xff\x00\x00\x00\x00\xd4\xff\x00\x00\xd6\xff\xb8\xff\xb9\xff\x00\x00\xd1\xff\x00\x00\xcb\xff\xcf\xff\xce\xff\xcc\xff\xf1\xfe\xb7\xff\x15\xff\xb4\xff\x26\xff\x11\xff\x12\xff\x00\x00\xf1\xfe\x00\x00\xb3\xff\xb2\xff\x23\xff\x00\x00\xf0\xfe\x00\x00\x00\x00\xf0\xfe\xf1\xfe\x00\x00\x35\xff\xf0\xfe\xf1\xfe\x3c\xff\xf0\xfe\x78\xff\x74\xff\x79\xff\x7c\xff\x7a\xff\x7b\xff\x7d\xff\x73\xff\x77\xff\xa8\xff\x6c\xff\x62\xff\x63\xff\x61\xff\xf1\xfe\x5a\xff\x00\x00\x5f\xff\x5e\xff\x00\x00\x68\xff\x69\xff\x5d\xff\x00\x00\x00\x00\xf1\xfe\x42\xff\xf1\xfe\xf0\xfe\x00\x00\xf1\xfe\x89\xff\xf0\xfe\xf1\xfe\x00\x00\x24\xff\x22\xff\x10\xff\x25\xff\x13\xff\xe9\xff\x00\x00\xca\xff\xd0\xff\xd3\xff\xe2\xff\xd5\xff\x00\x00\x1a\xff\x1f\xff\xbd\xff\xe3\xff\x91\xff\x00\x00\xf0\xfe\xe5\xff\xf1\xfe\x9a\xff\x00\x00\xf1\xfe\x00\x00\x59\xff\x66\xff\x5b\xff\x37\xff\x00\x00\x00\x00\xe7\xff\xf1\xfe\xcd\xff\x92\xff\x00\x00\x90\xff\x00\x00\xe6\xff\x3a\xff\x36\xff\x8f\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x03\x00\x01\x00\x0b\x00\x25\x00\x03\x00\x08\x00\x1a\x00\x29\x00\x1a\x00\x02\x00\x03\x00\x02\x00\x0c\x00\x0c\x00\x1a\x00\x12\x00\x10\x00\x4c\x00\x0b\x00\x13\x00\x0a\x00\x21\x00\x4c\x00\x1a\x00\x11\x00\x12\x00\x13\x00\x4c\x00\x15\x00\x01\x00\x17\x00\x02\x00\x19\x00\x20\x00\x21\x00\x16\x00\x1d\x00\x2a\x00\x1d\x00\x1a\x00\x0c\x00\x22\x00\x23\x00\x4d\x00\x10\x00\x26\x00\x27\x00\x2a\x00\x27\x00\x45\x00\x46\x00\x45\x00\x46\x00\x2e\x00\x2f\x00\x2e\x00\x41\x00\x4c\x00\x1d\x00\x31\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x25\x00\x01\x00\x1a\x00\x4d\x00\x3c\x00\x1d\x00\x2e\x00\x4b\x00\x4d\x00\x4e\x00\x4d\x00\x43\x00\x0c\x00\x4d\x00\x2a\x00\x54\x00\x10\x00\x02\x00\x57\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x5a\x00\x5b\x00\x01\x00\x5d\x00\x11\x00\x02\x00\x03\x00\x1a\x00\x4d\x00\x4e\x00\x25\x00\x4d\x00\x4d\x00\x0c\x00\x0b\x00\x54\x00\x1d\x00\x10\x00\x57\x00\x74\x00\x13\x00\x4d\x00\x13\x00\x78\x00\x15\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x20\x00\x21\x00\x25\x00\x1d\x00\x2e\x00\x4c\x00\x7d\x00\x11\x00\x22\x00\x23\x00\x20\x00\x21\x00\x1a\x00\x27\x00\x02\x00\x1a\x00\x1a\x00\x25\x00\x74\x00\x43\x00\x2e\x00\x4d\x00\x78\x00\x4c\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x07\x00\x11\x00\x25\x00\x25\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x1d\x00\x4d\x00\x4b\x00\x20\x00\x02\x00\x03\x00\x1a\x00\x1b\x00\x4d\x00\x4e\x00\x27\x00\x42\x00\x4b\x00\x0b\x00\x42\x00\x54\x00\x4d\x00\x2e\x00\x57\x00\x11\x00\x12\x00\x13\x00\x25\x00\x15\x00\x07\x00\x17\x00\x05\x00\x19\x00\x4d\x00\x4d\x00\x4d\x00\x1d\x00\x34\x00\x02\x00\x03\x00\x4c\x00\x22\x00\x23\x00\x3a\x00\x4c\x00\x26\x00\x27\x00\x0b\x00\x1a\x00\x1b\x00\x25\x00\x02\x00\x74\x00\x2e\x00\x2f\x00\x13\x00\x78\x00\x15\x00\x7a\x00\x7b\x00\x7c\x00\x25\x00\x4c\x00\x7d\x00\x26\x00\x1d\x00\x11\x00\x4d\x00\x25\x00\x4c\x00\x22\x00\x23\x00\x02\x00\x03\x00\x34\x00\x27\x00\x1a\x00\x25\x00\x1d\x00\x25\x00\x3a\x00\x0b\x00\x2e\x00\x2e\x00\x25\x00\x30\x00\x24\x00\x26\x00\x25\x00\x13\x00\x4d\x00\x15\x00\x03\x00\x02\x00\x03\x00\x2e\x00\x01\x00\x5a\x00\x5b\x00\x1d\x00\x5d\x00\x4d\x00\x0b\x00\x25\x00\x22\x00\x23\x00\x4d\x00\x12\x00\x4d\x00\x27\x00\x13\x00\x10\x00\x15\x00\x25\x00\x02\x00\x03\x00\x2e\x00\x4d\x00\x11\x00\x4d\x00\x1d\x00\x0a\x00\x0b\x00\x0b\x00\x4d\x00\x22\x00\x23\x00\x1a\x00\x4d\x00\x25\x00\x27\x00\x13\x00\x7d\x00\x15\x00\x25\x00\x02\x00\x03\x00\x2e\x00\x0a\x00\x0b\x00\x25\x00\x1d\x00\x25\x00\x4d\x00\x0b\x00\x25\x00\x22\x00\x23\x00\x1a\x00\x01\x00\x25\x00\x27\x00\x13\x00\x4d\x00\x15\x00\x21\x00\x02\x00\x03\x00\x2e\x00\x0d\x00\x0e\x00\x7d\x00\x1d\x00\x25\x00\x10\x00\x0b\x00\x25\x00\x22\x00\x23\x00\x4d\x00\x1a\x00\x25\x00\x27\x00\x13\x00\x4d\x00\x15\x00\x20\x00\x02\x00\x03\x00\x2e\x00\x4d\x00\x1a\x00\x4d\x00\x1d\x00\x1a\x00\x4d\x00\x0b\x00\x25\x00\x22\x00\x23\x00\x4d\x00\x24\x00\x13\x00\x27\x00\x13\x00\x7d\x00\x15\x00\x1a\x00\x02\x00\x03\x00\x2e\x00\x1e\x00\x1f\x00\x4d\x00\x1d\x00\x20\x00\x4d\x00\x0b\x00\x1a\x00\x22\x00\x23\x00\x4d\x00\x02\x00\x1a\x00\x27\x00\x13\x00\x7d\x00\x15\x00\x24\x00\x02\x00\x03\x00\x2e\x00\x23\x00\x1a\x00\x42\x00\x1d\x00\x1a\x00\x4d\x00\x0b\x00\x1a\x00\x22\x00\x23\x00\x23\x00\x21\x00\x1a\x00\x27\x00\x13\x00\x7d\x00\x15\x00\x1d\x00\x02\x00\x03\x00\x2e\x00\x4c\x00\x22\x00\x23\x00\x1d\x00\x1a\x00\x1a\x00\x0b\x00\x1d\x00\x22\x00\x23\x00\x13\x00\x20\x00\x4c\x00\x27\x00\x13\x00\x7d\x00\x15\x00\x1a\x00\x02\x00\x03\x00\x2e\x00\x02\x00\x03\x00\x1a\x00\x1d\x00\x0a\x00\x1a\x00\x0b\x00\x0d\x00\x22\x00\x23\x00\x28\x00\x20\x00\x4d\x00\x27\x00\x13\x00\x7d\x00\x15\x00\x18\x00\x19\x00\x31\x00\x2e\x00\x33\x00\x34\x00\x0a\x00\x1d\x00\x37\x00\x0d\x00\x1d\x00\x3a\x00\x22\x00\x23\x00\x4c\x00\x22\x00\x23\x00\x27\x00\x1a\x00\x7d\x00\x27\x00\x4c\x00\x1e\x00\x1f\x00\x2e\x00\x4c\x00\x49\x00\x2e\x00\x2e\x00\x4d\x00\x30\x00\x3d\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x02\x00\x03\x00\x4d\x00\x01\x00\x7d\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0d\x00\x0e\x00\x2d\x00\x09\x00\x2d\x00\x10\x00\x31\x00\x32\x00\x31\x00\x14\x00\x4c\x00\x16\x00\x7d\x00\x18\x00\x1d\x00\x3a\x00\x1b\x00\x3a\x00\x4c\x00\x22\x00\x23\x00\x18\x00\x19\x00\x26\x00\x27\x00\x48\x00\x25\x00\x4a\x00\x48\x00\x28\x00\x4a\x00\x2e\x00\x48\x00\x7d\x00\x4a\x00\x1a\x00\x48\x00\x4c\x00\x4a\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x4c\x00\x28\x00\x4f\x00\x50\x00\x5e\x00\x5f\x00\x7d\x00\x48\x00\x49\x00\x7d\x00\x31\x00\x4d\x00\x33\x00\x34\x00\x4c\x00\x2a\x00\x37\x00\x55\x00\x56\x00\x3a\x00\x3b\x00\x1a\x00\x51\x00\x52\x00\x53\x00\x2f\x00\x4c\x00\x4c\x00\x57\x00\x58\x00\x5d\x00\x4c\x00\x47\x00\x01\x00\x02\x00\x5e\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x0e\x00\x0f\x00\x10\x00\x75\x00\x76\x00\x77\x00\x14\x00\x03\x00\x16\x00\x4c\x00\x18\x00\x4c\x00\x08\x00\x1b\x00\x4d\x00\x1d\x00\x4d\x00\x4d\x00\x4d\x00\x4c\x00\x22\x00\x23\x00\x12\x00\x25\x00\x26\x00\x4d\x00\x28\x00\x4c\x00\x4c\x00\x4c\x00\x1a\x00\x4c\x00\x2e\x00\x4c\x00\x4c\x00\x4c\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x4f\x00\x4c\x00\x51\x00\x52\x00\x53\x00\x4c\x00\x4c\x00\x4c\x00\x57\x00\x58\x00\x59\x00\x01\x00\x02\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x4d\x00\x4d\x00\x09\x00\x03\x00\x0e\x00\x0f\x00\x10\x00\x4d\x00\x08\x00\x4d\x00\x14\x00\x1a\x00\x16\x00\x4c\x00\x18\x00\x1a\x00\x4c\x00\x1b\x00\x12\x00\x1d\x00\x4c\x00\x0e\x00\x02\x00\x03\x00\x22\x00\x23\x00\x1a\x00\x25\x00\x4c\x00\x4c\x00\x28\x00\x02\x00\x03\x00\x1a\x00\x1b\x00\x4c\x00\x06\x00\x1e\x00\x1f\x00\x4c\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\x4c\x00\x4c\x00\x2d\x00\x4d\x00\x22\x00\x23\x00\x31\x00\x32\x00\x1d\x00\x27\x00\x4d\x00\x4d\x00\x4c\x00\x22\x00\x23\x00\x3a\x00\x2e\x00\x4c\x00\x27\x00\x4f\x00\x4c\x00\x51\x00\x52\x00\x53\x00\x4d\x00\x2e\x00\x2f\x00\x57\x00\x58\x00\x59\x00\x01\x00\x4d\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x4c\x00\x4c\x00\x1a\x00\x1b\x00\x0e\x00\x0f\x00\x10\x00\x4d\x00\x4c\x00\x4c\x00\x14\x00\x2a\x00\x16\x00\x2b\x00\x18\x00\x4c\x00\x2a\x00\x1b\x00\x4c\x00\x1d\x00\x4d\x00\x2d\x00\x5b\x00\x02\x00\x03\x00\x31\x00\x4c\x00\x25\x00\x4c\x00\x2a\x00\x28\x00\x02\x00\x03\x00\x05\x00\x3a\x00\x1a\x00\x4d\x00\x4d\x00\x4d\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x4d\x00\x1d\x00\x05\x00\x1a\x00\x1a\x00\x19\x00\x22\x00\x23\x00\x4d\x00\x1d\x00\x4d\x00\x27\x00\x1a\x00\x1a\x00\x22\x00\x23\x00\x02\x00\x03\x00\x2e\x00\x27\x00\x4f\x00\x0e\x00\x51\x00\x52\x00\x53\x00\x0b\x00\x2e\x00\x17\x00\x57\x00\x58\x00\x59\x00\x01\x00\x06\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x4d\x00\x4d\x00\x4d\x00\x1d\x00\x0e\x00\x0f\x00\x10\x00\x1a\x00\x22\x00\x23\x00\x14\x00\x4d\x00\x16\x00\x27\x00\x18\x00\x1a\x00\x26\x00\x1b\x00\x4d\x00\x1d\x00\x2e\x00\x4d\x00\x5a\x00\x02\x00\x03\x00\x1a\x00\x48\x00\x25\x00\x13\x00\x11\x00\x28\x00\x02\x00\x03\x00\x11\x00\x15\x00\x15\x00\x15\x00\x2e\x00\x11\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x26\x00\x1d\x00\x03\x00\x17\x00\x13\x00\x4a\x00\x22\x00\x23\x00\x10\x00\x1d\x00\x26\x00\x27\x00\x04\x00\x13\x00\x22\x00\x23\x00\x02\x00\x03\x00\x2e\x00\x27\x00\x4f\x00\x15\x00\x51\x00\x52\x00\x53\x00\x26\x00\x2e\x00\x11\x00\x57\x00\x58\x00\x59\x00\x01\x00\x12\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x11\x00\x26\x00\x14\x00\x1d\x00\x0e\x00\x0f\x00\x10\x00\x0c\x00\x22\x00\x23\x00\x14\x00\x0b\x00\x16\x00\x27\x00\x18\x00\x2e\x00\x14\x00\x1b\x00\x14\x00\x1d\x00\x2e\x00\x20\x00\x02\x00\x03\x00\x2e\x00\x11\x00\x11\x00\x25\x00\x11\x00\x11\x00\x28\x00\x02\x00\x03\x00\x1a\x00\x1b\x00\x11\x00\x14\x00\x2e\x00\x2e\x00\x13\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\x15\x00\x11\x00\x2d\x00\x11\x00\x22\x00\x23\x00\x31\x00\x0a\x00\x1d\x00\x27\x00\x15\x00\x13\x00\x31\x00\x22\x00\x23\x00\x3a\x00\x2e\x00\x26\x00\x27\x00\x4f\x00\x20\x00\x51\x00\x52\x00\x53\x00\x14\x00\x2e\x00\x0b\x00\x57\x00\x58\x00\x59\x00\x01\x00\x26\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x04\x00\x20\x00\x0b\x00\x13\x00\x0e\x00\x0f\x00\x10\x00\x20\x00\x26\x00\x11\x00\x14\x00\x11\x00\x16\x00\x0a\x00\x18\x00\x11\x00\x13\x00\x1b\x00\x13\x00\x1d\x00\x13\x00\x13\x00\x02\x00\x03\x00\x02\x00\x03\x00\x13\x00\x25\x00\x0b\x00\x15\x00\x28\x00\x26\x00\x5e\x00\x0c\x00\x0b\x00\x31\x00\x20\x00\x11\x00\x26\x00\x11\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\x13\x00\x1d\x00\x0d\x00\x15\x00\x22\x00\x23\x00\x22\x00\x23\x00\x26\x00\x27\x00\x26\x00\x27\x00\x15\x00\x0b\x00\x13\x00\x13\x00\x2e\x00\x11\x00\x2e\x00\x4f\x00\x11\x00\x51\x00\x52\x00\x53\x00\x26\x00\x11\x00\x0a\x00\x57\x00\x58\x00\x59\x00\x01\x00\x26\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x03\x00\x1a\x00\x1b\x00\x26\x00\x0e\x00\x0f\x00\x10\x00\x13\x00\x20\x00\x2f\x00\x14\x00\x0a\x00\x16\x00\x11\x00\x18\x00\x0a\x00\x26\x00\x1b\x00\x03\x00\x1d\x00\x2d\x00\x11\x00\x5d\x00\x11\x00\x31\x00\x11\x00\x0a\x00\x25\x00\x0a\x00\x12\x00\x28\x00\x02\x00\x03\x00\x3a\x00\x0b\x00\x0b\x00\x11\x00\x10\x00\x1a\x00\x1b\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x04\x00\x04\x00\x01\x00\x12\x00\x04\x00\x19\x00\x10\x00\x41\x00\x2d\x00\x1d\x00\x10\x00\x10\x00\x31\x00\x14\x00\x22\x00\x23\x00\x02\x00\x03\x00\x26\x00\x27\x00\x4f\x00\x3a\x00\x51\x00\x52\x00\x53\x00\x0b\x00\x2e\x00\x12\x00\x57\x00\x58\x00\x59\x00\x01\x00\x0c\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x12\x00\x12\x00\x12\x00\x1d\x00\x0e\x00\x0f\x00\x10\x00\x12\x00\x22\x00\x23\x00\x14\x00\x05\x00\x16\x00\x27\x00\x18\x00\x7d\x00\x7d\x00\x1b\x00\x20\x00\x1d\x00\x2e\x00\xff\xff\x02\x00\x03\x00\x02\x00\x03\x00\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\x0b\x00\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\xff\xff\x1d\x00\xff\xff\xff\xff\x22\x00\x23\x00\x22\x00\x23\x00\xff\xff\x27\x00\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x2e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\x01\x00\xff\xff\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\xff\xff\xff\xff\x02\x00\x03\x00\x02\x00\x03\x00\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\xff\xff\x1d\x00\xff\xff\xff\xff\x22\x00\x23\x00\x22\x00\x23\x00\xff\xff\x27\x00\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x2e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\x01\x00\xff\xff\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\xff\xff\xff\xff\x02\x00\x03\x00\x02\x00\x03\x00\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\xff\xff\x1d\x00\xff\xff\xff\xff\x22\x00\x23\x00\x22\x00\x23\x00\xff\xff\x27\x00\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x2e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x1a\x00\x1b\x00\x57\x00\x58\x00\x59\x00\x01\x00\xff\xff\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\x2d\x00\x10\x00\xff\xff\xff\xff\x31\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x3a\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x03\x00\x25\x00\x0a\x00\x0b\x00\x28\x00\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x20\x00\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x23\x00\xff\xff\x01\x00\xff\xff\x27\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x2e\x00\x0b\x00\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\xff\xff\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\x0b\x00\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x28\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x31\x00\x1b\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\x01\x00\x31\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\x3a\x00\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\xff\xff\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x01\x00\x31\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x3a\x00\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x28\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x31\x00\x1b\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\x0b\x00\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x28\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x31\x00\x1b\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\x01\x00\x31\x00\xff\xff\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\x3a\x00\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x11\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x11\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x11\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x11\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\xff\xff\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x28\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x31\x00\x1b\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\x3b\x00\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x28\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x31\x00\x1b\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x25\x00\xff\xff\xff\xff\x01\x00\x1a\x00\x1b\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x22\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x2c\x00\x2d\x00\x16\x00\xff\xff\x18\x00\x31\x00\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x02\x00\x03\x00\x01\x00\x02\x00\xff\xff\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\xff\xff\x1d\x00\x57\x00\x58\x00\x1d\x00\xff\xff\x22\x00\x23\x00\xff\xff\x22\x00\x23\x00\x27\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x01\x00\xff\xff\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x10\x00\x1a\x00\xff\xff\x1c\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x31\x00\xff\xff\x33\x00\x34\x00\x35\x00\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x01\x00\xff\xff\xff\xff\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x4d\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x00\x52\x00\x53\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\xff\xff\x01\x00\x1a\x00\x1b\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x22\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x10\x00\xff\xff\xff\xff\xff\xff\x2c\x00\x2d\x00\x52\x00\x53\x00\x18\x00\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x03\x00\x3a\x00\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\x13\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x2e\x00\x2f\x00\xff\xff\x31\x00\xff\xff\xff\xff\x52\x00\x53\x00\x0c\x00\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\x15\x00\xff\xff\x41\x00\xff\xff\xff\xff\x1a\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x4a\x00\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x0c\x00\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\x0c\x00\x14\x00\x15\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x1a\x00\x14\x00\x15\x00\x00\x00\x01\x00\x02\x00\x03\x00\x1a\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x0c\x00\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\x15\x00\x00\x00\x01\x00\x02\x00\x03\x00\x1a\x00\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x0c\x00\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\x0c\x00\x14\x00\x15\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x1a\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x31\x00\xff\xff\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\x1a\x00\x3a\x00\x1c\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x4d\x00\xff\xff\xff\xff\x31\x00\xff\xff\x33\x00\x34\x00\xff\xff\x31\x00\x37\x00\x33\x00\x34\x00\x3a\x00\xff\xff\x37\x00\xff\xff\x1a\x00\x3a\x00\x1c\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x4d\x00\xff\xff\x26\x00\x27\x00\x28\x00\x4d\x00\xff\xff\xff\xff\x31\x00\xff\xff\x33\x00\x34\x00\xff\xff\x31\x00\x37\x00\x33\x00\x34\x00\x3a\x00\x0e\x00\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\xff\xff\xff\xff\x0e\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x4d\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x31\x00\xff\xff\x33\x00\x34\x00\x35\x00\xff\xff\x37\x00\xff\xff\x31\x00\x3a\x00\x33\x00\x34\x00\x35\x00\x1a\x00\x37\x00\x1c\x00\xff\xff\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x22\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x36\x00\x37\x00\x3a\x00\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\x35\x00\x22\x00\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x36\x00\x37\x00\x3a\x00\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x22\x00\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\x3a\x00\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x22\x00\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\x3a\x00\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x22\x00\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\x3a\x00\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x22\x00\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\x3a\x00\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\x1a\x00\xff\xff\x37\x00\xff\xff\x28\x00\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\x31\x00\x28\x00\x33\x00\x34\x00\x1a\x00\x31\x00\x37\x00\x33\x00\x34\x00\x3a\x00\x31\x00\x37\x00\x33\x00\x34\x00\x3a\x00\xff\xff\x37\x00\x1a\x00\x28\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x31\x00\xff\xff\x33\x00\x34\x00\x28\x00\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x1a\x00\x28\x00\x31\x00\xff\xff\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\x31\x00\x3a\x00\x33\x00\x34\x00\x28\x00\xff\xff\x37\x00\x1a\x00\xff\xff\x3a\x00\xff\xff\xff\xff\xff\xff\x31\x00\xff\xff\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\x28\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\xff\xff\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x19\x02\x25\x00\x30\x02\xbf\x00\xc3\x00\x6c\x02\xfd\x01\x04\x01\xfd\x01\xc2\x00\xc3\x00\xf6\x00\x57\x00\xd9\xff\x72\x02\x4d\x00\x58\x00\x88\x02\x9d\xff\xfc\xff\xec\x00\x8b\x02\x7f\x02\x50\x00\x9d\xff\x9d\xff\x9d\xff\x81\x02\x9d\xff\x25\x00\x9d\xff\xf6\x00\x9d\xff\xd9\xff\xd9\xff\x71\x01\xc4\x00\x89\x01\xf7\x00\x72\x01\x57\x00\xc5\x00\xc6\x00\xc0\x00\x58\x00\x9d\xff\xc7\x00\x0c\x01\xb0\x01\x65\x02\xff\x01\xfe\x01\xff\x01\xc8\x00\x9d\xff\xf8\x00\x5e\x00\x75\x02\xf7\x00\x70\xff\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xbf\x00\x25\x00\xbb\x00\xc8\x00\x73\x01\xcc\x01\xf8\x00\xd9\xff\x62\x00\x63\x00\x82\x02\x74\x01\x57\x00\x3f\x01\x0c\x01\x64\x00\x58\x00\xf6\x00\x65\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x9d\xff\x9d\xff\x25\x00\x9d\xff\x3e\x02\xc2\x00\xc3\x00\x72\x01\x62\x00\x63\x00\xbf\x00\x76\x02\x79\x02\x57\x00\x06\xff\x64\x00\xf7\x00\x58\x00\x65\x00\x66\x00\xfc\xff\xc8\x00\x06\xff\x67\x00\x06\xff\x68\x00\x69\x00\x6a\x00\xfc\xff\x28\x01\x29\x01\xbf\x00\xc4\x00\xf8\x00\x77\x02\x9d\xff\x70\x02\xc5\x00\xc6\x00\x42\x01\x43\x01\x44\x01\xc7\x00\xf6\x00\x44\x01\x4e\x01\xbf\x00\x66\x00\x00\x02\xc8\x00\x59\x02\x67\x00\x7a\x02\x68\x00\x69\x00\x6a\x00\xfc\xff\x25\x01\xae\x01\xbf\x00\xbf\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xf7\x00\x5c\x02\x2a\x01\xaf\x01\xc2\x00\xc3\x00\x7d\x00\x7e\x00\x62\x00\x63\x00\xb0\x01\x6e\x02\x2a\x01\x9c\xff\x45\x01\x64\x00\xc0\x00\xf8\x00\x65\x00\x9c\xff\x9c\xff\x9c\xff\xbf\x00\x9c\xff\x7c\x00\x9c\xff\x85\x02\x9c\xff\x57\x02\x37\x02\xc0\x00\xc4\x00\x7f\x00\xc2\x00\xc3\x00\x7b\x02\xc5\x00\xc6\x00\x80\x00\x56\x02\x9c\xff\xc7\x00\x08\xff\x7d\x00\x7e\x00\xbf\x00\xf6\x00\x66\x00\xc8\x00\x9c\xff\x08\xff\x67\x00\x08\xff\x68\x00\x69\x00\x6a\x00\xbf\x00\x58\x02\x06\xff\x86\x02\xc4\x00\x6b\xff\x88\x01\xbf\x00\x5b\x02\xc5\x00\xc6\x00\xc2\x00\xc3\x00\x7f\x00\xc7\x00\x97\x00\xbf\x00\xf7\x00\xbf\x00\x80\x00\x0c\xff\xc8\x00\x4d\x02\xbf\x00\x7d\x02\x5d\x02\x6b\xff\xbf\x00\x0c\xff\x9c\x01\x0c\xff\x9c\x00\xc2\x00\xc3\x00\xf8\x00\x25\x00\x9c\xff\x9c\xff\xc4\x00\x9c\xff\x9e\x01\x0b\xff\xbf\x00\xc5\x00\xc6\x00\x5f\x02\x9d\x00\xa0\x01\xc7\x00\x0b\xff\x58\x00\x0b\xff\xbf\x00\xc2\x00\xc3\x00\xc8\x00\xa2\x01\x4d\x01\xc0\x00\xc4\x00\x69\x02\x1f\x02\x09\xff\xbb\x01\xc5\x00\xc6\x00\x4e\x01\xbe\x01\xbf\x00\xc7\x00\x09\xff\x9c\xff\x09\xff\xbf\x00\xc2\x00\xc3\x00\xc8\x00\x1e\x02\x1f\x02\xbf\x00\xc4\x00\xfb\x00\xbf\x01\x07\xff\xbf\x00\xc5\x00\xc6\x00\x72\x02\x25\x00\xbf\x00\xc7\x00\x07\xff\xc0\x01\x07\xff\x86\x02\xc2\x00\xc3\x00\xc8\x00\xf4\x01\x24\x01\x08\xff\xc4\x00\xbf\x00\x58\x00\x02\xff\xbf\x00\xc5\x00\xc6\x00\xc1\x01\xd6\x00\xfb\x00\xc7\x00\x02\xff\xc2\x01\x02\xff\xaa\x01\xc2\x00\xc3\x00\xc8\x00\xc0\x00\x85\x01\xfc\x00\xc4\x00\x44\x01\xc0\x00\x01\xff\xbf\x00\xc5\x00\xc6\x00\x14\x01\x98\x00\x32\x01\xc7\x00\x01\xff\x0c\xff\x01\xff\xec\x00\xc2\x00\xc3\x00\xc8\x00\xcf\x01\xee\x00\x16\x01\xc4\x00\x33\x01\xc0\x00\xfe\xfe\x97\x00\xc5\x00\xc6\x00\xfc\x00\x79\x00\x48\x01\xc7\x00\xfe\xfe\x0b\xff\xfe\xfe\x98\x00\xc2\x00\xc3\x00\xc8\x00\x59\x01\x48\x01\x47\x01\xc4\x00\x72\x02\xc0\x00\xfd\xfe\x60\x02\xc5\x00\xc6\x00\x49\x01\x73\x02\x6d\x02\xc7\x00\xfd\xfe\x09\xff\xfd\xfe\x7a\x00\xc2\x00\xc3\x00\xc8\x00\x62\x02\x7b\x00\x7c\x00\xc4\x00\xbb\x00\xd6\x00\xfc\xfe\xbc\x00\xc5\x00\xc6\x00\x8a\x00\xc3\x01\x66\x02\xc7\x00\xfc\xfe\x07\xff\xfc\xfe\x1a\x00\xc2\x00\xc3\x00\xc8\x00\xc2\x00\xc3\x00\x14\x02\xc4\x00\xb2\x01\xd6\x00\xfb\xfe\x70\xff\xc5\x00\xc6\x00\x1e\x00\xd7\x00\x25\x02\xc7\x00\xfb\xfe\x02\xff\xfb\xfe\xf8\x01\x2b\x01\x1f\x00\xc8\x00\x8b\x00\x21\x00\xec\x00\xc4\x00\x22\x00\x70\xff\xc4\x00\x23\x00\xc5\x00\xc6\x00\x1b\x02\xc5\x00\xc6\x00\xc7\x00\xec\x00\x01\xff\xc7\x00\x1d\x02\xed\x00\xee\x00\xc8\x00\x26\x02\x8c\x00\xc8\x00\x4d\x02\x2d\x02\x4e\x02\x2e\x02\x7d\x00\xb2\x00\x7d\x00\xb2\x00\xc2\x00\xc3\x00\x3b\x02\x25\x00\xfe\xfe\x8e\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x8f\x00\x23\x01\x24\x01\xd3\x01\x33\x02\x53\x02\x2e\x00\xb6\x00\xd4\x01\xb6\x00\x2f\x00\x30\x02\x30\x00\xfd\xfe\x31\x00\xc4\x00\x80\x00\x32\x00\x80\x00\x31\x02\xc5\x00\xc6\x00\x2a\x01\x2b\x01\x36\x02\xc7\x00\x0d\x01\x34\x00\xe9\x01\x0d\x01\x35\x00\x70\x01\xc8\x00\x0d\x01\xfc\xfe\x0e\x01\x1a\x00\x0d\x01\x47\x02\x0f\x01\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x49\x02\x1e\x00\x50\x02\x51\x02\xa7\x00\xa8\x00\xfb\xfe\x2d\x01\x2e\x01\xff\xff\x1f\x00\x4c\x02\x29\x02\x21\x00\x4a\x02\xf0\x01\x22\x00\x21\x02\x22\x02\x23\x00\x2a\x02\x06\x00\x40\x00\x41\x00\x42\x00\xd1\x01\x4b\x02\xc4\x01\x43\x00\x44\x00\x8a\xff\xc5\x01\x2b\x02\x25\x00\xad\x00\x90\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xc6\x01\xc7\x01\xc8\x01\xc9\x01\x2c\x00\x2d\x00\x2e\x00\x23\x02\x24\x02\x25\x02\x2f\x00\x19\x02\x30\x00\xca\x01\x31\x00\xcb\x01\x1a\x02\x32\x00\xd6\x01\xae\x00\xd7\x01\xd8\x01\xda\x01\xdc\x01\xaf\x00\xb0\x00\x4d\x00\x34\x00\xb1\x00\xf9\x01\x35\x00\xde\x01\xe0\x01\xe1\x01\x50\x00\xe2\x01\xb2\x00\xe3\x01\xe4\x01\xe5\x01\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x3f\x00\xe6\x01\x40\x00\x41\x00\x42\x00\xe7\x01\xec\x01\xef\x01\x43\x00\x44\x00\x45\x00\x25\x00\x79\x00\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xfa\x01\x01\x02\x03\x02\x19\x02\x2c\x00\x2d\x00\x2e\x00\x05\x02\x34\x02\x07\x02\x2f\x00\x0c\x02\x30\x00\x52\x01\x31\x00\x55\x01\x57\x01\x32\x00\x4d\x00\xae\x00\x61\x01\x77\x00\xc2\x00\xc3\x00\x7b\x00\x7c\x00\x50\x00\x34\x00\x62\x01\x66\x01\x35\x00\xc2\x00\xc3\x00\xef\x00\xb2\x00\x67\x01\x7e\x01\xf0\x00\xee\x00\x8a\x01\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xc4\x00\x8b\x01\x8c\x01\xf1\x00\x8e\x01\xc5\x00\xc6\x00\xb6\x00\xf2\x00\xc4\x00\xc7\x00\x9b\x01\x9d\x01\x9f\x01\xc5\x00\xc6\x00\x80\x00\xc8\x00\xa1\x01\xc7\x00\x3f\x00\xa3\x01\x40\x00\x41\x00\x42\x00\xb8\x01\xc8\x00\x51\x01\x43\x00\x44\x00\x45\x00\x25\x00\xb9\x01\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xbd\x01\xdc\x00\x7d\x00\xb2\x00\x2c\x00\x2d\x00\x2e\x00\xe2\x00\xe5\x00\xe8\x00\x2f\x00\xea\x00\x30\x00\xf9\x00\x31\x00\x10\x01\x1e\x01\x32\x00\x17\x01\x33\x00\x15\x01\x52\x02\xf3\x01\xc2\x00\xc3\x00\xb6\x00\x18\x01\x34\x00\x1f\x01\x22\x01\x35\x00\xc2\x00\xc3\x00\x26\x01\x80\x00\x2e\x01\x3a\x01\x3b\x01\x3e\x01\xd2\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x01\xc4\x00\x40\x01\x46\x01\x71\x00\xee\x01\xc5\x00\xc6\x00\x4a\x01\xc4\x00\x4f\x01\xc7\x00\x72\x00\x73\x00\xc5\x00\xc6\x00\xc2\x00\xc3\x00\xc8\x00\xc7\x00\x3f\x00\x77\x00\x40\x00\x41\x00\x42\x00\x16\x02\xc8\x00\x90\x00\x43\x00\x44\x00\x45\x00\x25\x00\x92\x00\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x9a\x00\x9d\x00\x9e\x00\xc4\x00\x2c\x00\x2d\x00\x2e\x00\xa0\x00\xc5\x00\xc6\x00\x2f\x00\xa5\x00\x30\x00\xc7\x00\x31\x00\xcf\x00\x88\x02\x32\x00\xbd\x00\x33\x00\xc8\x00\xc8\x00\x21\x01\xc2\x00\xc3\x00\xd5\x00\x04\x00\x34\x00\x8a\x02\x84\x02\x35\x00\xc2\x00\xc3\x00\x7d\x02\x72\x02\x75\x02\x55\x02\xf8\x00\x40\xff\xd4\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x56\x02\xc4\x00\x00\x00\x12\x01\x5f\x02\x62\x02\xc5\x00\xc6\x00\x68\x02\xc4\x00\x66\x01\xc7\x00\x69\x02\x6c\x02\xc5\x00\xc6\x00\xc2\x00\xc3\x00\xc8\x00\xc7\x00\x3f\x00\x6b\x02\x40\x00\x41\x00\x42\x00\x14\x02\xc8\x00\x70\x02\x43\x00\x44\x00\x45\x00\x25\x00\xf6\x01\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x17\x02\x18\x02\x19\x02\xc4\x00\x2c\x00\x2d\x00\x2e\x00\x28\x02\xc5\x00\xc6\x00\x2f\x00\x29\x02\x30\x00\xc7\x00\x31\x00\x52\x02\x33\x02\x32\x00\x05\x02\x33\x00\xc8\x00\x39\x02\xc2\x00\xc3\x00\xcf\x01\x3f\x02\x40\x02\x34\x00\x41\x02\x42\x02\x35\x00\xc2\x00\xc3\x00\x7d\x00\xb2\x00\x43\x02\xd3\x01\xf8\x00\xda\x01\x87\xff\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xc4\x00\x3d\xff\xde\x01\xd5\x01\xe0\x01\xc5\x00\xc6\x00\xb6\x00\xec\x00\xc4\x00\xc7\x00\xeb\x01\x03\x02\xef\x01\xc5\x00\xc6\x00\x80\x00\xc8\x00\xec\x01\xc7\x00\x3f\x00\xfd\x01\x40\x00\x41\x00\x42\x00\x05\x02\xc8\x00\x0f\x02\x43\x00\x44\x00\x45\x00\x25\x00\x10\x02\x1e\x01\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x11\x02\x54\x01\x12\x02\x55\x01\x2c\x00\x2d\x00\x2e\x00\x59\x01\x5c\x01\x5b\x01\x2f\x00\x5d\x01\x30\x00\x5e\x01\x31\x00\x64\x01\x69\x01\x32\x00\x6a\x01\x33\x00\x6b\x01\x6c\x01\xc2\x00\xc3\x00\x06\x01\xc3\x00\x6d\x01\x34\x00\x70\x01\x7a\x01\x35\x00\x79\x01\x7b\x01\x94\x00\x81\x01\x85\x01\x82\x01\x65\x01\x80\x01\x07\x01\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xc4\x00\x88\x01\x08\x01\x95\x01\x92\x01\xc5\x00\xc6\x00\x09\x01\x0a\x01\x66\x01\xc7\x00\x0b\x01\xc7\x00\x93\x01\x94\x01\xa5\x01\xa7\x01\xc8\x00\xad\x01\x0c\x01\x3f\x00\xb1\x01\x40\x00\x41\x00\x42\x00\xb3\x01\xb4\x01\xb5\x01\x43\x00\x44\x00\x45\x00\x25\x00\xb7\x01\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x7d\x00\xb2\x00\xda\x00\x2c\x00\x2d\x00\x2e\x00\xe7\x00\xe4\x00\xea\x00\x2f\x00\xec\x00\x30\x00\xf9\x00\x31\x00\xfb\x00\xf5\x00\x32\x00\x00\x00\x33\x00\xe8\x01\xc3\xff\x22\x01\xc4\xff\xb6\x00\x03\x01\xec\x00\x34\x00\xec\x00\x30\x01\x35\x00\xc2\x00\xc3\x00\x80\x00\x34\x01\x4c\x01\x44\x01\x4d\x01\x7d\x00\xb2\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x6b\x00\x6c\x00\x6e\x00\x6f\x00\x71\x00\x13\x01\x75\x00\x70\x00\xa5\x01\xc4\x00\x76\x00\x77\x00\xb6\x00\x92\x00\xc5\x00\xc6\x00\xc2\x00\xc3\x00\x14\x01\xc7\x00\x3f\x00\x80\x00\x40\x00\x41\x00\x42\x00\xf7\x01\xc8\x00\x86\x00\x43\x00\x44\x00\x45\x00\x25\x00\x94\x00\x1e\x01\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x87\x00\x88\x00\x89\x00\xc4\x00\x2c\x00\x2d\x00\x2e\x00\x8a\x00\xc5\x00\xc6\x00\x2f\x00\x95\x00\x30\x00\xc7\x00\x31\x00\xff\xff\xff\xff\x32\x00\xbf\x00\x33\x00\xc8\x00\x00\x00\xc2\x00\xc3\x00\xc2\x00\xc3\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\xf8\x01\x00\x00\x0a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xc4\x00\x00\x00\xc4\x00\x00\x00\x00\x00\xc5\x00\xc6\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\xc8\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x25\x00\x00\x00\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x33\x00\x00\x00\x00\x00\xc2\x00\xc3\x00\xc2\x00\xc3\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x0b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x02\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xc4\x00\x00\x00\xc4\x00\x00\x00\x00\x00\xc5\x00\xc6\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\xc8\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x25\x00\x00\x00\x1e\x01\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x33\x00\x00\x00\x00\x00\xc2\x00\xc3\x00\xc2\x00\xc3\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x13\x02\x00\x00\x00\x00\x00\x00\x00\x00\x09\x02\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xc4\x00\x00\x00\xc4\x00\x00\x00\x00\x00\xc5\x00\xc6\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\xc8\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x7d\x00\xb2\x00\x43\x00\x44\x00\x45\x00\x25\x00\x00\x00\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x8b\x02\x00\x00\x00\x00\x00\x00\xa7\x01\x2e\x00\x00\x00\x00\x00\xb6\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x80\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\xc3\x00\x34\x00\x76\x01\x77\x01\x35\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x78\x01\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\xc6\x00\x00\x00\x25\x00\x00\x00\xc7\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xc8\x00\x7f\x02\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x00\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x1a\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x79\x02\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x1e\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x1f\x00\x32\x00\x8b\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x01\x00\x00\x00\x00\x25\x00\xb6\x00\x8e\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x80\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x00\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x01\x00\x00\xa9\x01\x00\x00\x00\x00\x25\x00\xb6\x00\x1a\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2d\x02\x80\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x1e\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x1f\x00\x32\x00\x8b\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x01\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x1a\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x3a\x02\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x1e\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x1f\x00\x32\x00\x8b\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x01\x00\x00\x00\x00\x25\x00\xb6\x00\x00\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x80\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x44\x02\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x45\x02\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x46\x02\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x47\x02\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x8e\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x00\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x1a\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x1e\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x1f\x00\x32\x00\x29\x02\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x64\x02\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x1a\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x1e\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x1f\x00\x32\x00\xba\x01\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x63\x02\xb5\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\xc3\x00\x25\x00\x79\x00\x00\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x01\xb9\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x7a\x00\x00\x00\xc5\x00\xc6\x00\x00\x00\x7b\x00\x7c\x00\xc7\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xbb\x00\x25\x00\x00\x00\xb8\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xba\x00\x1a\x00\x00\x00\x96\x01\x00\x00\x00\x00\x00\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x21\x00\x97\x01\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xbb\x00\x25\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x98\x01\x56\x01\x47\x00\x48\x00\x49\x00\x00\x00\xb9\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x84\x00\x85\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x00\x00\x4e\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xbb\x00\x00\x00\x25\x00\x7d\x00\xb2\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\xb3\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x82\x00\x00\x00\x00\x00\x00\x00\x48\x02\xb5\x00\x84\x00\x85\x00\x31\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\xff\xc3\x00\x80\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x65\xff\x65\xff\x65\xff\x00\x00\x00\x00\x00\x00\x65\xff\x00\x00\x65\xff\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x65\xff\x00\x00\x00\x00\x65\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\xff\x65\xff\x00\x00\x00\x00\x35\x01\x47\x00\x48\x00\x49\x00\x65\xff\x65\xff\x00\x00\x65\xff\x00\x00\x00\x00\x84\x00\x85\x00\x4a\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x00\x00\x4e\x00\x4f\x00\x00\x00\x65\xff\x00\x00\x00\x00\x50\x00\x36\x01\x47\x00\x48\x00\x49\x00\x00\x00\x65\xff\x00\x00\x37\x01\x47\x00\x48\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x4a\x00\x4e\x00\x4f\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x50\x00\x4e\x00\x4f\x00\x38\x01\x47\x00\x48\x00\x49\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x00\x00\x4e\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x01\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x4a\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x00\x00\x4e\x00\x4f\x00\x95\x00\x47\x00\x48\x00\x49\x00\x50\x00\x00\x00\x00\x00\x96\x00\x47\x00\x48\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x4a\x00\x4e\x00\x4f\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x50\x00\x4e\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x46\x00\x47\x00\x48\x00\x49\x00\x00\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x00\x00\x4e\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x1f\x00\x00\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x1a\x00\x23\x00\xe1\x00\x00\x00\x00\x00\x1a\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x95\x01\x00\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x21\x00\x00\x00\x1f\x00\x22\x00\x20\x00\x21\x00\x23\x00\x00\x00\x22\x00\x00\x00\x1a\x00\x23\x00\xfd\x00\x00\x00\x00\x00\x1a\x00\x00\x00\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x99\x01\x00\x00\x1c\x00\x1d\x00\x1e\x00\x9a\x01\x00\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x21\x00\x00\x00\x1f\x00\x22\x00\x20\x00\x21\x00\x23\x00\x77\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\xfe\x00\x00\x00\x1a\x00\x00\x00\x3c\x01\x00\x01\x1c\x00\x1d\x00\x1e\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x20\x00\x21\x00\xab\x00\x00\x00\x22\x00\x00\x00\x1f\x00\x23\x00\x20\x00\x21\x00\x3d\x01\x19\x01\x22\x00\x1a\x01\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x01\x1f\x00\x1a\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x80\x02\x1c\x01\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x01\x1f\x00\x1a\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x86\x01\x1c\x01\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x1a\x00\x1f\x00\x8f\x01\x20\x00\x21\x00\x00\x00\xb3\x00\x22\x00\x1b\x01\x1c\x01\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\xcd\x01\xb5\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x1a\x00\x1f\x00\x96\x01\x20\x00\x21\x00\x00\x00\x3c\x02\x22\x00\x80\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x1a\x00\x1f\x00\x8f\x01\x20\x00\x21\x00\x97\x01\xb3\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\xcd\x01\xd0\x01\x00\x00\x00\x00\x00\x00\xb6\x00\x1a\x00\x1f\x00\x5a\x02\x20\x00\x21\x00\x00\x00\x90\x01\x22\x00\x80\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x1a\x00\x1f\x00\x36\x02\x20\x00\x21\x00\x00\x00\xb3\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\xfb\x01\xb5\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x1a\x00\x1f\x00\x3a\x02\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x80\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x1a\x00\x1f\x00\xf1\x01\x20\x00\x21\x00\x00\x00\xb3\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x0b\x02\xb5\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x1a\x00\x1f\x00\xf3\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x80\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x1a\x00\x1f\x00\x0d\x02\x20\x00\x21\x00\x00\x00\xb3\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x30\x01\xb5\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x1a\x00\x1f\x00\x51\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x80\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x1a\x00\x1f\x00\x5e\x01\x20\x00\x21\x00\x00\x00\xb3\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\xb4\x00\xb5\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x1a\x00\x1f\x00\x5f\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x80\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x60\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x6d\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x7b\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x7c\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x7d\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x82\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x83\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x8d\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xdf\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xe0\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xb7\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xbc\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xda\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xdb\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xdd\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xde\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xdf\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xe0\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xe1\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xe4\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xf3\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xa1\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x01\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x03\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x6c\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x99\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x9f\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xa1\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xa3\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xa4\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xc9\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xca\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xcb\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xcc\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xcd\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xce\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xd0\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xd2\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xd4\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xd8\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x1b\x00\x20\x00\x21\x00\x1a\x00\x00\x00\x22\x00\x00\x00\x1e\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1e\x00\xba\x01\x21\x00\x1a\x00\x1f\x00\x22\x00\x20\x00\x21\x00\x23\x00\x1f\x00\x22\x00\xba\x01\x21\x00\x23\x00\x00\x00\x22\x00\x1a\x00\x1e\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x1f\x00\x00\x00\xdb\x01\x21\x00\x1e\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1a\x00\x1e\x00\x1f\x00\x00\x00\xba\x01\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x1f\x00\x23\x00\xba\x01\x21\x00\x1e\x00\x00\x00\x22\x00\x1a\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\xe7\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x1e\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\xa2\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (3, 272) [ - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50), - (51 , happyReduce_51), - (52 , happyReduce_52), - (53 , happyReduce_53), - (54 , happyReduce_54), - (55 , happyReduce_55), - (56 , happyReduce_56), - (57 , happyReduce_57), - (58 , happyReduce_58), - (59 , happyReduce_59), - (60 , happyReduce_60), - (61 , happyReduce_61), - (62 , happyReduce_62), - (63 , happyReduce_63), - (64 , happyReduce_64), - (65 , happyReduce_65), - (66 , happyReduce_66), - (67 , happyReduce_67), - (68 , happyReduce_68), - (69 , happyReduce_69), - (70 , happyReduce_70), - (71 , happyReduce_71), - (72 , happyReduce_72), - (73 , happyReduce_73), - (74 , happyReduce_74), - (75 , happyReduce_75), - (76 , happyReduce_76), - (77 , happyReduce_77), - (78 , happyReduce_78), - (79 , happyReduce_79), - (80 , happyReduce_80), - (81 , happyReduce_81), - (82 , happyReduce_82), - (83 , happyReduce_83), - (84 , happyReduce_84), - (85 , happyReduce_85), - (86 , happyReduce_86), - (87 , happyReduce_87), - (88 , happyReduce_88), - (89 , happyReduce_89), - (90 , happyReduce_90), - (91 , happyReduce_91), - (92 , happyReduce_92), - (93 , happyReduce_93), - (94 , happyReduce_94), - (95 , happyReduce_95), - (96 , happyReduce_96), - (97 , happyReduce_97), - (98 , happyReduce_98), - (99 , happyReduce_99), - (100 , happyReduce_100), - (101 , happyReduce_101), - (102 , happyReduce_102), - (103 , happyReduce_103), - (104 , happyReduce_104), - (105 , happyReduce_105), - (106 , happyReduce_106), - (107 , happyReduce_107), - (108 , happyReduce_108), - (109 , happyReduce_109), - (110 , happyReduce_110), - (111 , happyReduce_111), - (112 , happyReduce_112), - (113 , happyReduce_113), - (114 , happyReduce_114), - (115 , happyReduce_115), - (116 , happyReduce_116), - (117 , happyReduce_117), - (118 , happyReduce_118), - (119 , happyReduce_119), - (120 , happyReduce_120), - (121 , happyReduce_121), - (122 , happyReduce_122), - (123 , happyReduce_123), - (124 , happyReduce_124), - (125 , happyReduce_125), - (126 , happyReduce_126), - (127 , happyReduce_127), - (128 , happyReduce_128), - (129 , happyReduce_129), - (130 , happyReduce_130), - (131 , happyReduce_131), - (132 , happyReduce_132), - (133 , happyReduce_133), - (134 , happyReduce_134), - (135 , happyReduce_135), - (136 , happyReduce_136), - (137 , happyReduce_137), - (138 , happyReduce_138), - (139 , happyReduce_139), - (140 , happyReduce_140), - (141 , happyReduce_141), - (142 , happyReduce_142), - (143 , happyReduce_143), - (144 , happyReduce_144), - (145 , happyReduce_145), - (146 , happyReduce_146), - (147 , happyReduce_147), - (148 , happyReduce_148), - (149 , happyReduce_149), - (150 , happyReduce_150), - (151 , happyReduce_151), - (152 , happyReduce_152), - (153 , happyReduce_153), - (154 , happyReduce_154), - (155 , happyReduce_155), - (156 , happyReduce_156), - (157 , happyReduce_157), - (158 , happyReduce_158), - (159 , happyReduce_159), - (160 , happyReduce_160), - (161 , happyReduce_161), - (162 , happyReduce_162), - (163 , happyReduce_163), - (164 , happyReduce_164), - (165 , happyReduce_165), - (166 , happyReduce_166), - (167 , happyReduce_167), - (168 , happyReduce_168), - (169 , happyReduce_169), - (170 , happyReduce_170), - (171 , happyReduce_171), - (172 , happyReduce_172), - (173 , happyReduce_173), - (174 , happyReduce_174), - (175 , happyReduce_175), - (176 , happyReduce_176), - (177 , happyReduce_177), - (178 , happyReduce_178), - (179 , happyReduce_179), - (180 , happyReduce_180), - (181 , happyReduce_181), - (182 , happyReduce_182), - (183 , happyReduce_183), - (184 , happyReduce_184), - (185 , happyReduce_185), - (186 , happyReduce_186), - (187 , happyReduce_187), - (188 , happyReduce_188), - (189 , happyReduce_189), - (190 , happyReduce_190), - (191 , happyReduce_191), - (192 , happyReduce_192), - (193 , happyReduce_193), - (194 , happyReduce_194), - (195 , happyReduce_195), - (196 , happyReduce_196), - (197 , happyReduce_197), - (198 , happyReduce_198), - (199 , happyReduce_199), - (200 , happyReduce_200), - (201 , happyReduce_201), - (202 , happyReduce_202), - (203 , happyReduce_203), - (204 , happyReduce_204), - (205 , happyReduce_205), - (206 , happyReduce_206), - (207 , happyReduce_207), - (208 , happyReduce_208), - (209 , happyReduce_209), - (210 , happyReduce_210), - (211 , happyReduce_211), - (212 , happyReduce_212), - (213 , happyReduce_213), - (214 , happyReduce_214), - (215 , happyReduce_215), - (216 , happyReduce_216), - (217 , happyReduce_217), - (218 , happyReduce_218), - (219 , happyReduce_219), - (220 , happyReduce_220), - (221 , happyReduce_221), - (222 , happyReduce_222), - (223 , happyReduce_223), - (224 , happyReduce_224), - (225 , happyReduce_225), - (226 , happyReduce_226), - (227 , happyReduce_227), - (228 , happyReduce_228), - (229 , happyReduce_229), - (230 , happyReduce_230), - (231 , happyReduce_231), - (232 , happyReduce_232), - (233 , happyReduce_233), - (234 , happyReduce_234), - (235 , happyReduce_235), - (236 , happyReduce_236), - (237 , happyReduce_237), - (238 , happyReduce_238), - (239 , happyReduce_239), - (240 , happyReduce_240), - (241 , happyReduce_241), - (242 , happyReduce_242), - (243 , happyReduce_243), - (244 , happyReduce_244), - (245 , happyReduce_245), - (246 , happyReduce_246), - (247 , happyReduce_247), - (248 , happyReduce_248), - (249 , happyReduce_249), - (250 , happyReduce_250), - (251 , happyReduce_251), - (252 , happyReduce_252), - (253 , happyReduce_253), - (254 , happyReduce_254), - (255 , happyReduce_255), - (256 , happyReduce_256), - (257 , happyReduce_257), - (258 , happyReduce_258), - (259 , happyReduce_259), - (260 , happyReduce_260), - (261 , happyReduce_261), - (262 , happyReduce_262), - (263 , happyReduce_263), - (264 , happyReduce_264), - (265 , happyReduce_265), - (266 , happyReduce_266), - (267 , happyReduce_267), - (268 , happyReduce_268), - (269 , happyReduce_269), - (270 , happyReduce_270), - (271 , happyReduce_271), - (272 , happyReduce_272) - ] - -happy_n_terms = 126 :: Int -happy_n_nonterms = 79 :: Int - -happyReduce_3 = happySpecReduce_0 0# happyReduction_3 -happyReduction_3 = happyIn6 - ([] - ) - -happyReduce_4 = happySpecReduce_2 0# happyReduction_4 -happyReduction_4 happy_x_2 - happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn6 - (happy_var_1:happy_var_2 - )}} - -happyReduce_5 = happySpecReduce_2 0# happyReduction_5 -happyReduction_5 happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn6 - (map RealDecl happy_var_1 ++ happy_var_2 - )}} - -happyReduce_6 = happyReduce 4# 0# happyReduction_6 -happyReduction_6 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> - case happyOut6 happy_x_4 of { happy_var_4 -> - happyIn6 - (RealDecl (PInclude happy_var_2) : happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_7 = happySpecReduce_1 1# happyReduction_7 -happyReduction_7 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn7 - (happy_var_1 - )} - -happyReduce_8 = happySpecReduce_1 1# happyReduction_8 -happyReduction_8 happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - happyIn7 - (RealDecl (DataDecl happy_var_1) - )} - -happyReduce_9 = happySpecReduce_1 1# happyReduction_9 -happyReduction_9 happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - happyIn7 - (RealDecl happy_var_1 - )} - -happyReduce_10 = happyReduce 5# 1# happyReduction_10 -happyReduction_10 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokenName happy_var_2) -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn7 - (RealDecl (Freeze happy_var_3 happy_var_4 [] happy_var_2) - ) `HappyStk` happyRest}}} - -happyReduce_11 = happyReduce 4# 1# happyReduction_11 -happyReduction_11 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut67 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn7 - (PUsing happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_12 = happyReduce 4# 1# happyReduction_12 -happyReduction_12 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut68 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn7 - (PDoUsing happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_13 = happyReduce 4# 1# happyReduction_13 -happyReduction_13 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut69 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn7 - (PIdiom happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_14 = happyReduce 4# 1# happyReduction_14 -happyReduction_14 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut70 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn7 - (PParams happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_15 = happyReduce 4# 1# happyReduction_15 -happyReduction_15 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut71 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn7 - (PNamespace happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_16 = happySpecReduce_1 1# happyReduction_16 -happyReduction_16 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn7 - (RealDecl happy_var_1 - )} - -happyReduce_17 = happyReduce 6# 1# happyReduction_17 -happyReduction_17 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut41 happy_x_3 of { happy_var_3 -> - case happyOut34 happy_x_5 of { happy_var_5 -> - happyIn7 - (RealDecl (SynDef happy_var_2 happy_var_3 happy_var_5) - ) `HappyStk` happyRest}}} - -happyReduce_18 = happyReduce 5# 1# happyReduction_18 -happyReduction_18 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn7 - (RealDecl (SynDef happy_var_2 [] (RVar happy_var_3 happy_var_4 (mkhidden happy_var_2) Unknown)) - ) `HappyStk` happyRest}}} - -happyReduce_19 = happySpecReduce_2 1# happyReduction_19 -happyReduction_19 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> - happyIn7 - (RealDecl (CInclude happy_var_2) - )} - -happyReduce_20 = happySpecReduce_2 1# happyReduction_20 -happyReduction_20 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> - happyIn7 - (RealDecl (CLib happy_var_2) - )} - -happyReduce_21 = happyReduce 5# 2# happyReduction_21 -happyReduction_21 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - happyIn8 - (Transform happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_22 = happyReduce 7# 3# happyReduction_22 -happyReduction_22 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - case happyOut15 happy_x_5 of { happy_var_5 -> - case happyOut83 happy_x_6 of { happy_var_6 -> - case happyOut82 happy_x_7 of { happy_var_7 -> - happyIn9 - (FunType happy_var_1 happy_var_3 (nub happy_var_5) happy_var_6 happy_var_7 - ) `HappyStk` happyRest}}}}} - -happyReduce_23 = happySpecReduce_3 3# happyReduction_23 -happyReduction_23 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut79 happy_x_2 of { happy_var_2 -> - happyIn9 - (ProofScript happy_var_1 happy_var_2 - )}} - -happyReduce_24 = happyReduce 9# 3# happyReduction_24 -happyReduction_24 (happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_3 of { happy_var_3 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut14 happy_x_6 of { happy_var_6 -> - case happyOut83 happy_x_8 of { happy_var_8 -> - case happyOut82 happy_x_9 of { happy_var_9 -> - happyIn9 - (WithClause (mkDef happy_var_8 happy_var_9 happy_var_1) happy_var_2 happy_var_3 happy_var_4 happy_var_6 - ) `HappyStk` happyRest}}}}}}} - -happyReduce_25 = happyReduce 10# 3# happyReduction_25 -happyReduction_25 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut32 happy_x_7 of { happy_var_7 -> - case happyOut83 happy_x_9 of { happy_var_9 -> - case happyOut82 happy_x_10 of { happy_var_10 -> - happyIn9 - (FunClauseP (mkDef happy_var_9 happy_var_10 happy_var_1) happy_var_2 happy_var_4 happy_var_7 - ) `HappyStk` happyRest}}}}}} - -happyReduce_26 = happyReduce 8# 3# happyReduction_26 -happyReduction_26 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut15 happy_x_6 of { happy_var_6 -> - case happyOut83 happy_x_7 of { happy_var_7 -> - case happyOut82 happy_x_8 of { happy_var_8 -> - happyIn9 - (FunClause (mkDef happy_var_7 happy_var_8 happy_var_1) happy_var_2 happy_var_4 (nub happy_var_6) - ) `HappyStk` happyRest}}}}}} - -happyReduce_27 = happyReduce 5# 3# happyReduction_27 -happyReduction_27 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut13 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - happyIn9 - (FunClause RPlaceholder [happy_var_2] happy_var_4 [] - ) `HappyStk` happyRest}} - -happyReduce_28 = happyReduce 8# 3# happyReduction_28 -happyReduction_28 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut13 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut32 happy_x_7 of { happy_var_7 -> - happyIn9 - (FunClauseP RPlaceholder [happy_var_2] happy_var_4 happy_var_7 - ) `HappyStk` happyRest}}} - -happyReduce_29 = happyReduce 7# 3# happyReduction_29 -happyReduction_29 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut13 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_3 of { happy_var_3 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut14 happy_x_6 of { happy_var_6 -> - happyIn9 - (WithClause RPlaceholder [happy_var_2] happy_var_3 happy_var_4 happy_var_6 - ) `HappyStk` happyRest}}}} - -happyReduce_30 = happySpecReduce_1 4# happyReduction_30 -happyReduction_30 happy_x_1 - = happyIn10 - (Vis Public - ) - -happyReduce_31 = happySpecReduce_1 4# happyReduction_31 -happyReduction_31 happy_x_1 - = happyIn10 - (Vis Private - ) - -happyReduce_32 = happySpecReduce_1 4# happyReduction_32 -happyReduction_32 happy_x_1 - = happyIn10 - (Vis Abstract - ) - -happyReduce_33 = happySpecReduce_0 4# happyReduction_33 -happyReduction_33 = happyIn10 - (Vis Public - ) - -happyReduce_34 = happySpecReduce_1 5# happyReduction_34 -happyReduction_34 happy_x_1 - = happyIn11 - (False - ) - -happyReduce_35 = happySpecReduce_2 5# happyReduction_35 -happyReduction_35 happy_x_2 - happy_x_1 - = happyIn11 - (True - ) - -happyReduce_36 = happySpecReduce_3 6# happyReduction_36 -happyReduction_36 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut13 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn12 - (happy_var_2:happy_var_3 - )}} - -happyReduce_37 = happySpecReduce_0 6# happyReduction_37 -happyReduction_37 = happyIn12 - ([] - ) - -happyReduce_38 = happySpecReduce_1 7# happyReduction_38 -happyReduction_38 happy_x_1 - = case happyOut33 happy_x_1 of { happy_var_1 -> - happyIn13 - (happy_var_1 - )} - -happyReduce_39 = happySpecReduce_1 7# happyReduction_39 -happyReduction_39 happy_x_1 - = case happyOut58 happy_x_1 of { happy_var_1 -> - happyIn13 - (happy_var_1 - )} - -happyReduce_40 = happySpecReduce_3 7# happyReduction_40 -happyReduction_40 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn13 - (happy_var_2 - )} - -happyReduce_41 = happyReduce 5# 7# happyReduction_41 -happyReduction_41 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut59 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn13 - (pairDesugar happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "mkPair") Unknown) happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_42 = happySpecReduce_2 8# happyReduction_42 -happyReduction_42 happy_x_2 - happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut14 happy_x_2 of { happy_var_2 -> - happyIn14 - (happy_var_1:happy_var_2 - )}} - -happyReduce_43 = happySpecReduce_1 8# happyReduction_43 -happyReduction_43 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn14 - ([happy_var_1] - )} - -happyReduce_44 = happySpecReduce_3 9# happyReduction_44 -happyReduction_44 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut16 happy_x_2 of { happy_var_2 -> - happyIn15 - (happy_var_2 - )} - -happyReduce_45 = happySpecReduce_0 9# happyReduction_45 -happyReduction_45 = happyIn15 - ([] - ) - -happyReduce_46 = happySpecReduce_0 10# happyReduction_46 -happyReduction_46 = happyIn16 - ([] - ) - -happyReduce_47 = happySpecReduce_2 10# happyReduction_47 -happyReduction_47 happy_x_2 - happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - case happyOut16 happy_x_2 of { happy_var_2 -> - happyIn16 - (happy_var_1 ++ happy_var_2 - )}} - -happyReduce_48 = happySpecReduce_1 11# happyReduction_48 -happyReduction_48 happy_x_1 - = happyIn17 - ([NoCG] - ) - -happyReduce_49 = happySpecReduce_1 11# happyReduction_49 -happyReduction_49 happy_x_1 - = happyIn17 - ([CGEval, Inline] - ) - -happyReduce_50 = happyReduce 4# 11# happyReduction_50 -happyReduction_50 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut39 happy_x_3 of { happy_var_3 -> - happyIn17 - ([CGSpec happy_var_3] - ) `HappyStk` happyRest} - -happyReduce_51 = happySpecReduce_1 11# happyReduction_51 -happyReduction_51 happy_x_1 - = happyIn17 - ([CGSpec []] - ) - -happyReduce_52 = happySpecReduce_1 11# happyReduction_52 -happyReduction_52 happy_x_1 - = happyIn17 - ([Inline] - ) - -happyReduce_53 = happySpecReduce_2 11# happyReduction_53 -happyReduction_53 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> - happyIn17 - ([CExport happy_var_2] - )} - -happyReduce_54 = happyReduce 4# 12# happyReduction_54 -happyReduction_54 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut21 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokenInt happy_var_2) -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn18 - (map (\x -> Fixity x happy_var_1 happy_var_2) happy_var_3 - ) `HappyStk` happyRest}}} - -happyReduce_55 = happySpecReduce_1 13# happyReduction_55 -happyReduction_55 happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - happyIn19 - ([happy_var_1] - )} - -happyReduce_56 = happySpecReduce_3 13# happyReduction_56 -happyReduction_56 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn19 - (happy_var_1:happy_var_3 - )}} - -happyReduce_57 = happySpecReduce_1 14# happyReduction_57 -happyReduction_57 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenInfixName happy_var_1) -> - happyIn20 - (happy_var_1 - )} - -happyReduce_58 = happySpecReduce_1 14# happyReduction_58 -happyReduction_58 happy_x_1 - = happyIn20 - ("-" - ) - -happyReduce_59 = happySpecReduce_1 14# happyReduction_59 -happyReduction_59 happy_x_1 - = happyIn20 - ("<" - ) - -happyReduce_60 = happySpecReduce_1 14# happyReduction_60 -happyReduction_60 happy_x_1 - = happyIn20 - (">" - ) - -happyReduce_61 = happySpecReduce_1 15# happyReduction_61 -happyReduction_61 happy_x_1 - = happyIn21 - (LeftAssoc - ) - -happyReduce_62 = happySpecReduce_1 15# happyReduction_62 -happyReduction_62 happy_x_1 - = happyIn21 - (RightAssoc - ) - -happyReduce_63 = happySpecReduce_1 15# happyReduction_63 -happyReduction_63 happy_x_1 - = happyIn21 - (NonAssoc - ) - -happyReduce_64 = happyReduce 4# 16# happyReduction_64 -happyReduction_64 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut23 happy_x_3 of { happy_var_3 -> - happyIn22 - (LatexDefs happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_65 = happySpecReduce_3 17# happyReduction_65 -happyReduction_65 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_3 of { (TokenString happy_var_3) -> - happyIn23 - ([(happy_var_1,happy_var_3)] - )}} - -happyReduce_66 = happyReduce 5# 17# happyReduction_66 -happyReduction_66 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_3 of { (TokenString happy_var_3) -> - case happyOut23 happy_x_5 of { happy_var_5 -> - happyIn23 - ((happy_var_1,happy_var_3):happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_67 = happySpecReduce_2 18# happyReduction_67 -happyReduction_67 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut25 happy_x_2 of { happy_var_2 -> - happyIn24 - ((happy_var_1, happy_var_2) - )}} - -happyReduce_68 = happySpecReduce_0 19# happyReduction_68 -happyReduction_68 = happyIn25 - ([] - ) - -happyReduce_69 = happySpecReduce_2 19# happyReduction_69 -happyReduction_69 happy_x_2 - happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - case happyOut25 happy_x_2 of { happy_var_2 -> - happyIn25 - ((happy_var_1,Nothing):happy_var_2 - )}} - -happyReduce_70 = happyReduce 5# 19# happyReduction_70 -happyReduction_70 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokenBrackName happy_var_1) -> - case happyOut25 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn25 - ((RVar happy_var_4 happy_var_5 happy_var_1 Unknown, Just happy_var_1):happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_71 = happyReduce 5# 19# happyReduction_71 -happyReduction_71 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokenBrackName happy_var_1) -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut25 happy_x_5 of { happy_var_5 -> - happyIn25 - ((happy_var_3, Just happy_var_1):happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_72 = happyReduce 6# 20# happyReduction_72 -happyReduction_72 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut27 happy_x_1 of { happy_var_1 -> - case happyOut29 happy_x_2 of { happy_var_2 -> - case happyOut32 happy_x_3 of { happy_var_3 -> - case happyOut28 happy_x_4 of { happy_var_4 -> - case happyOut83 happy_x_5 of { happy_var_5 -> - case happyOut82 happy_x_6 of { happy_var_6 -> - happyIn26 - (mkDatatype happy_var_1 happy_var_5 happy_var_6 happy_var_3 happy_var_4 happy_var_2 - ) `HappyStk` happyRest}}}}}} - -happyReduce_73 = happySpecReduce_1 21# happyReduction_73 -happyReduction_73 happy_x_1 - = happyIn27 - (False - ) - -happyReduce_74 = happySpecReduce_1 21# happyReduction_74 -happyReduction_74 happy_x_1 - = happyIn27 - (True - ) - -happyReduce_75 = happySpecReduce_3 22# happyReduction_75 -happyReduction_75 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut66 happy_x_1 of { happy_var_1 -> - case happyOut75 happy_x_2 of { happy_var_2 -> - happyIn28 - (Right (happy_var_1,happy_var_2) - )}} - -happyReduce_76 = happySpecReduce_3 22# happyReduction_76 -happyReduction_76 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut50 happy_x_2 of { happy_var_2 -> - happyIn28 - (Left happy_var_2 - )} - -happyReduce_77 = happySpecReduce_3 22# happyReduction_77 -happyReduction_77 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn28 - (Left (RConst happy_var_2 happy_var_3 TYPE) - )}} - -happyReduce_78 = happySpecReduce_0 23# happyReduction_78 -happyReduction_78 = happyIn29 - ([] - ) - -happyReduce_79 = happySpecReduce_3 23# happyReduction_79 -happyReduction_79 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut30 happy_x_2 of { happy_var_2 -> - happyIn29 - (happy_var_2 - )} - -happyReduce_80 = happySpecReduce_1 24# happyReduction_80 -happyReduction_80 happy_x_1 - = case happyOut31 happy_x_1 of { happy_var_1 -> - happyIn30 - ([happy_var_1] - )} - -happyReduce_81 = happySpecReduce_3 24# happyReduction_81 -happyReduction_81 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut31 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 - (happy_var_1:happy_var_3 - )}} - -happyReduce_82 = happySpecReduce_1 25# happyReduction_82 -happyReduction_82 happy_x_1 - = happyIn31 - (NoElim - ) - -happyReduce_83 = happySpecReduce_1 25# happyReduction_83 -happyReduction_83 happy_x_1 - = happyIn31 - (Collapsible - ) - -happyReduce_84 = happySpecReduce_1 26# happyReduction_84 -happyReduction_84 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenName happy_var_1) -> - happyIn32 - (happy_var_1 - )} - -happyReduce_85 = happySpecReduce_3 26# happyReduction_85 -happyReduction_85 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut20 happy_x_2 of { happy_var_2 -> - happyIn32 - (useropFn happy_var_2 - )} - -happyReduce_86 = happyReduce 4# 27# happyReduction_86 -happyReduction_86 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut33 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - case happyOut57 happy_x_4 of { happy_var_4 -> - happyIn33 - (RApp happy_var_2 happy_var_3 happy_var_1 happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_87 = happyReduce 5# 27# happyReduction_87 -happyReduction_87 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut33 happy_x_1 of { happy_var_1 -> - case happyOut43 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn33 - (RAppImp happy_var_4 happy_var_5 (fst happy_var_2) happy_var_1 (snd happy_var_2) - ) `HappyStk` happyRest}}}} - -happyReduce_88 = happySpecReduce_3 27# happyReduction_88 -happyReduction_88 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn33 - (RVar happy_var_2 happy_var_3 happy_var_1 Unknown - )}}} - -happyReduce_89 = happySpecReduce_3 27# happyReduction_89 -happyReduction_89 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut64 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn33 - (RConst happy_var_2 happy_var_3 happy_var_1 - )}}} - -happyReduce_90 = happySpecReduce_1 27# happyReduction_90 -happyReduction_90 happy_x_1 - = happyIn33 - (RPlaceholder - ) - -happyReduce_91 = happySpecReduce_3 27# happyReduction_91 -happyReduction_91 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn33 - (RVar happy_var_2 happy_var_3 (UN "__Empty") TypeCon - )}} - -happyReduce_92 = happySpecReduce_3 27# happyReduction_92 -happyReduction_92 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn33 - (RVar happy_var_2 happy_var_3 (UN "__Unit") TypeCon - )}} - -happyReduce_93 = happySpecReduce_1 28# happyReduction_93 -happyReduction_93 happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - happyIn34 - (happy_var_1 - )} - -happyReduce_94 = happySpecReduce_3 28# happyReduction_94 -happyReduction_94 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut50 happy_x_2 of { happy_var_2 -> - happyIn34 - (happy_var_2 - )} - -happyReduce_95 = happyReduce 4# 28# happyReduction_95 -happyReduction_95 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - case happyOut57 happy_x_4 of { happy_var_4 -> - happyIn34 - (RApp happy_var_2 happy_var_3 happy_var_1 happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_96 = happyReduce 5# 28# happyReduction_96 -happyReduction_96 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut43 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn34 - (RAppImp happy_var_4 happy_var_5 (fst happy_var_2) happy_var_1 (snd happy_var_2) - ) `HappyStk` happyRest}}}} - -happyReduce_97 = happyReduce 4# 28# happyReduction_97 -happyReduction_97 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn34 - (RApp happy_var_3 happy_var_4 (RApp happy_var_3 happy_var_4 (RVar happy_var_3 happy_var_4 (UN "__lazy") Free) RPlaceholder) happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_98 = happyReduce 4# 28# happyReduction_98 -happyReduction_98 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut35 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - happyIn34 - (doBind Lam happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_99 = happyReduce 4# 28# happyReduction_99 -happyReduction_99 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut42 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - happyIn34 - (doLetBind happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_100 = happySpecReduce_1 28# happyReduction_100 -happyReduction_100 happy_x_1 - = case happyOut44 happy_x_1 of { happy_var_1 -> - happyIn34 - (happy_var_1 - )} - -happyReduce_101 = happyReduce 8# 28# happyReduction_101 -happyReduction_101 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut34 happy_x_6 of { happy_var_6 -> - case happyOut83 happy_x_7 of { happy_var_7 -> - case happyOut82 happy_x_8 of { happy_var_8 -> - happyIn34 - (mkApp happy_var_7 happy_var_8 (RVar happy_var_7 happy_var_8 (UN "if_then_else") Free) [happy_var_2,happy_var_4,happy_var_6] - ) `HappyStk` happyRest}}}}} - -happyReduce_102 = happySpecReduce_2 29# happyReduction_102 -happyReduction_102 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut48 happy_x_2 of { happy_var_2 -> - happyIn35 - ([(happy_var_1,happy_var_2)] - )}} - -happyReduce_103 = happyReduce 4# 29# happyReduction_103 -happyReduction_103 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut48 happy_x_2 of { happy_var_2 -> - case happyOut35 happy_x_4 of { happy_var_4 -> - happyIn35 - ((happy_var_1,happy_var_2):happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_104 = happySpecReduce_3 30# happyReduction_104 -happyReduction_104 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut36 happy_x_3 of { happy_var_3 -> - happyIn36 - (happy_var_1 ++ happy_var_3 - )}} - -happyReduce_105 = happySpecReduce_1 30# happyReduction_105 -happyReduction_105 happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - happyIn36 - (happy_var_1 - )} - -happyReduce_106 = happySpecReduce_3 31# happyReduction_106 -happyReduction_106 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn37 - (map ( \x -> (x,happy_var_3)) [happy_var_1] - )}} - -happyReduce_107 = happySpecReduce_1 32# happyReduction_107 -happyReduction_107 happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - happyIn38 - ([happy_var_1] - )} - -happyReduce_108 = happySpecReduce_3 32# happyReduction_108 -happyReduction_108 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut38 happy_x_3 of { happy_var_3 -> - happyIn38 - (happy_var_1:happy_var_3 - )}} - -happyReduce_109 = happySpecReduce_2 33# happyReduction_109 -happyReduction_109 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokenInt happy_var_2) -> - happyIn39 - ([(happy_var_1,happy_var_2)] - )}} - -happyReduce_110 = happySpecReduce_1 33# happyReduction_110 -happyReduction_110 happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - happyIn39 - ([(happy_var_1, 0)] - )} - -happyReduce_111 = happySpecReduce_3 33# happyReduction_111 -happyReduction_111 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut39 happy_x_3 of { happy_var_3 -> - happyIn39 - ((happy_var_1,0):happy_var_3 - )}} - -happyReduce_112 = happyReduce 4# 33# happyReduction_112 -happyReduction_112 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokenInt happy_var_2) -> - case happyOut39 happy_x_4 of { happy_var_4 -> - happyIn39 - ((happy_var_1,happy_var_2):happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_113 = happySpecReduce_1 34# happyReduction_113 -happyReduction_113 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenBrackName happy_var_1) -> - happyIn40 - ([happy_var_1] - )} - -happyReduce_114 = happySpecReduce_3 34# happyReduction_114 -happyReduction_114 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokenBrackName happy_var_1) -> - case happyOut38 happy_x_3 of { happy_var_3 -> - happyIn40 - (happy_var_1:happy_var_3 - )}} - -happyReduce_115 = happySpecReduce_0 35# happyReduction_115 -happyReduction_115 = happyIn41 - ([] - ) - -happyReduce_116 = happySpecReduce_2 35# happyReduction_116 -happyReduction_116 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut41 happy_x_2 of { happy_var_2 -> - happyIn41 - (happy_var_1:happy_var_2 - )}} - -happyReduce_117 = happyReduce 4# 36# happyReduction_117 -happyReduction_117 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut48 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - happyIn42 - ([(happy_var_1,happy_var_2,happy_var_4)] - ) `HappyStk` happyRest}}} - -happyReduce_118 = happyReduce 6# 36# happyReduction_118 -happyReduction_118 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut48 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut42 happy_x_6 of { happy_var_6 -> - happyIn42 - ((happy_var_1,happy_var_2,happy_var_4):happy_var_6 - ) `HappyStk` happyRest}}}} - -happyReduce_119 = happySpecReduce_3 37# happyReduction_119 -happyReduction_119 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokenBrackName happy_var_1) -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn43 - ((happy_var_1, RVar happy_var_2 happy_var_3 happy_var_1 Unknown) - )}}} - -happyReduce_120 = happySpecReduce_3 37# happyReduction_120 -happyReduction_120 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokenBrackName happy_var_1) -> - case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn43 - ((happy_var_1, happy_var_3) - )}} - -happyReduce_121 = happyReduce 4# 38# happyReduction_121 -happyReduction_121 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn44 - (RInfix happy_var_3 happy_var_4 Minus (RConst happy_var_3 happy_var_4 (Num 0)) happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_122 = happyReduce 5# 38# happyReduction_122 -happyReduction_122 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn44 - (RUserInfix happy_var_4 happy_var_5 False "-" happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_123 = happyReduce 5# 38# happyReduction_123 -happyReduction_123 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn44 - (mkApp happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "Pair") TypeCon) [happy_var_1, happy_var_3] - ) `HappyStk` happyRest}}}} - -happyReduce_124 = happyReduce 5# 38# happyReduction_124 -happyReduction_124 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn44 - (RUserInfix happy_var_4 happy_var_5 False "<" happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_125 = happyReduce 5# 38# happyReduction_125 -happyReduction_125 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn44 - (RUserInfix happy_var_4 happy_var_5 False ">" happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_126 = happyReduce 5# 38# happyReduction_126 -happyReduction_126 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn44 - (RBind (MN "X" 0) (Pi Ex [] happy_var_1) happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_127 = happySpecReduce_1 38# happyReduction_127 -happyReduction_127 happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - happyIn44 - (happy_var_1 - )} - -happyReduce_128 = happyReduce 5# 38# happyReduction_128 -happyReduction_128 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut57 happy_x_1 of { happy_var_1 -> - case happyOut57 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn44 - (RInfix happy_var_4 happy_var_5 JMEq happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_129 = happyReduce 5# 39# happyReduction_129 -happyReduction_129 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokenInfixName happy_var_2) -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn45 - (RUserInfix happy_var_4 happy_var_5 False happy_var_2 happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}}} - -happyReduce_130 = happyReduce 6# 40# happyReduction_130 -happyReduction_130 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokenInfixName happy_var_2) -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix happy_var_4 happy_var_5 False happy_var_2 (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown) happy_var_3) - ) `HappyStk` happyRest}}}} - -happyReduce_131 = happyReduce 6# 40# happyReduction_131 -happyReduction_131 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { (TokenInfixName happy_var_3) -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix happy_var_4 happy_var_5 False happy_var_3 happy_var_2 (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown)) - ) `HappyStk` happyRest}}}} - -happyReduce_132 = happyReduce 6# 40# happyReduction_132 -happyReduction_132 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut47 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix happy_var_4 happy_var_5 False happy_var_2 (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown) happy_var_3) - ) `HappyStk` happyRest}}}} - -happyReduce_133 = happyReduce 6# 40# happyReduction_133 -happyReduction_133 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix happy_var_4 happy_var_5 False happy_var_3 happy_var_2 (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown)) - ) `HappyStk` happyRest}}}} - -happyReduce_134 = happyReduce 6# 40# happyReduction_134 -happyReduction_134 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix happy_var_4 happy_var_5 False "-" happy_var_2 (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown)) - ) `HappyStk` happyRest}}} - -happyReduce_135 = happyReduce 6# 40# happyReduction_135 -happyReduction_135 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RBind (MN "X" 1) (Pi Ex [] happy_var_2) (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown)) - ) `HappyStk` happyRest}}} - -happyReduce_136 = happyReduce 6# 40# happyReduction_136 -happyReduction_136 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RBind (MN "X" 1) (Pi Ex [] (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown)) happy_var_3) - ) `HappyStk` happyRest}}} - -happyReduce_137 = happyReduce 5# 40# happyReduction_137 -happyReduction_137 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RBind (MN "X" 1) (Lam RPlaceholder) - (RBind (MN "X" 2) (Pi Ex [] (RVar happy_var_3 happy_var_4 (MN "X" 0) Unknown)) - (RVar happy_var_3 happy_var_4 (MN "X" 1) Unknown))) - ) `HappyStk` happyRest}} - -happyReduce_138 = happyReduce 5# 40# happyReduction_138 -happyReduction_138 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RBind (MN "X" 1) (Lam RPlaceholder) - (pairDesugar happy_var_3 happy_var_4 (RVar happy_var_3 happy_var_4 (UN "mkPair") DataCon) - [RVar happy_var_3 happy_var_4 (MN "X" 0) Unknown, - RVar happy_var_3 happy_var_4 (MN "X" 1) Unknown])) - ) `HappyStk` happyRest}} - -happyReduce_139 = happyReduce 6# 40# happyReduction_139 -happyReduction_139 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (pairDesugar happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "mkPair") DataCon) - [happy_var_2, - RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown]) - ) `HappyStk` happyRest}}} - -happyReduce_140 = happyReduce 6# 40# happyReduction_140 -happyReduction_140 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (pairDesugar happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "mkPair") DataCon) - [RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown, happy_var_3]) - ) `HappyStk` happyRest}}} - -happyReduce_141 = happySpecReduce_1 41# happyReduction_141 -happyReduction_141 happy_x_1 - = happyIn47 - ("<" - ) - -happyReduce_142 = happySpecReduce_1 41# happyReduction_142 -happyReduction_142 happy_x_1 - = happyIn47 - (">" - ) - -happyReduce_143 = happySpecReduce_0 42# happyReduction_143 -happyReduction_143 = happyIn48 - (RPlaceholder - ) - -happyReduce_144 = happySpecReduce_2 42# happyReduction_144 -happyReduction_144 happy_x_2 - happy_x_1 - = case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn48 - (happy_var_2 - )} - -happyReduce_145 = happySpecReduce_0 43# happyReduction_145 -happyReduction_145 = happyIn49 - (RPlaceholder - ) - -happyReduce_146 = happySpecReduce_2 43# happyReduction_146 -happyReduction_146 happy_x_2 - happy_x_1 - = case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn49 - (happy_var_2 - )} - -happyReduce_147 = happyReduce 5# 44# happyReduction_147 -happyReduction_147 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut49 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_5 of { happy_var_5 -> - happyIn50 - (doBind (Pi Im []) (map (\x -> (x, happy_var_2)) happy_var_1) happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_148 = happySpecReduce_1 44# happyReduction_148 -happyReduction_148 happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - happyIn50 - (happy_var_1 - )} - -happyReduce_149 = happySpecReduce_3 45# happyReduction_149 -happyReduction_149 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_3 of { happy_var_3 -> - happyIn51 - (RBind (MN "X" 0) (Pi Ex [] happy_var_1) happy_var_3 - )}} - -happyReduce_150 = happyReduce 6# 45# happyReduction_150 -happyReduction_150 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut36 happy_x_2 of { happy_var_2 -> - case happyOut53 happy_x_4 of { happy_var_4 -> - case happyOut51 happy_x_6 of { happy_var_6 -> - happyIn51 - (doBind (Pi Ex happy_var_4) happy_var_2 happy_var_6 - ) `HappyStk` happyRest}}} - -happyReduce_151 = happyReduce 5# 45# happyReduction_151 -happyReduction_151 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut36 happy_x_2 of { happy_var_2 -> - case happyOut51 happy_x_5 of { happy_var_5 -> - happyIn51 - (doBind (Pi Ex [Lazy]) happy_var_2 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_152 = happySpecReduce_3 45# happyReduction_152 -happyReduction_152 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn51 - (bracket happy_var_2 - )} - -happyReduce_153 = happyReduce 7# 45# happyReduction_153 -happyReduction_153 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut51 happy_x_2 of { happy_var_2 -> - case happyOut51 happy_x_4 of { happy_var_4 -> - case happyOut83 happy_x_5 of { happy_var_5 -> - case happyOut82 happy_x_6 of { happy_var_6 -> - happyIn51 - (RInfix happy_var_5 happy_var_6 JMEq happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_154 = happySpecReduce_1 45# happyReduction_154 -happyReduction_154 happy_x_1 - = case happyOut33 happy_x_1 of { happy_var_1 -> - happyIn51 - (happy_var_1 - )} - -happyReduce_155 = happySpecReduce_3 45# happyReduction_155 -happyReduction_155 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn51 - (happy_var_2 - )} - -happyReduce_156 = happyReduce 5# 45# happyReduction_156 -happyReduction_156 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokenInfixName happy_var_2) -> - case happyOut51 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn51 - (RUserInfix happy_var_4 happy_var_5 False happy_var_2 happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}}} - -happyReduce_157 = happyReduce 5# 45# happyReduction_157 -happyReduction_157 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn51 - (RUserInfix happy_var_4 happy_var_5 False "-" happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_158 = happyReduce 5# 45# happyReduction_158 -happyReduction_158 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut56 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn51 - (pairDesugar happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "Pair") TypeCon) happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_159 = happySpecReduce_1 45# happyReduction_159 -happyReduction_159 happy_x_1 - = case happyOut55 happy_x_1 of { happy_var_1 -> - happyIn51 - (happy_var_1 - )} - -happyReduce_160 = happySpecReduce_1 46# happyReduction_160 -happyReduction_160 happy_x_1 - = happyIn52 - (Lazy - ) - -happyReduce_161 = happySpecReduce_1 46# happyReduction_161 -happyReduction_161 happy_x_1 - = happyIn52 - (Static - ) - -happyReduce_162 = happySpecReduce_3 47# happyReduction_162 -happyReduction_162 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut54 happy_x_2 of { happy_var_2 -> - happyIn53 - (happy_var_2 - )} - -happyReduce_163 = happySpecReduce_0 47# happyReduction_163 -happyReduction_163 = happyIn53 - ([] - ) - -happyReduce_164 = happySpecReduce_3 48# happyReduction_164 -happyReduction_164 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut52 happy_x_1 of { happy_var_1 -> - case happyOut54 happy_x_3 of { happy_var_3 -> - happyIn54 - (happy_var_1:happy_var_3 - )}} - -happyReduce_165 = happySpecReduce_1 48# happyReduction_165 -happyReduction_165 happy_x_1 - = case happyOut52 happy_x_1 of { happy_var_1 -> - happyIn54 - ([happy_var_1] - )} - -happyReduce_166 = happyReduce 8# 49# happyReduction_166 -happyReduction_166 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut51 happy_x_5 of { happy_var_5 -> - case happyOut83 happy_x_7 of { happy_var_7 -> - case happyOut82 happy_x_8 of { happy_var_8 -> - happyIn55 - (sigDesugar happy_var_7 happy_var_8 (happy_var_2, happy_var_3) happy_var_5 - ) `HappyStk` happyRest}}}}} - -happyReduce_167 = happySpecReduce_3 50# happyReduction_167 -happyReduction_167 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_3 of { happy_var_3 -> - happyIn56 - (happy_var_1:happy_var_3:[] - )}} - -happyReduce_168 = happySpecReduce_3 50# happyReduction_168 -happyReduction_168 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut56 happy_x_3 of { happy_var_3 -> - happyIn56 - (happy_var_1:happy_var_3 - )}} - -happyReduce_169 = happySpecReduce_3 51# happyReduction_169 -happyReduction_169 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn57 - (RVar happy_var_2 happy_var_3 happy_var_1 Unknown - )}}} - -happyReduce_170 = happySpecReduce_3 51# happyReduction_170 -happyReduction_170 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn57 - (RReturn happy_var_2 happy_var_3 - )}} - -happyReduce_171 = happySpecReduce_3 51# happyReduction_171 -happyReduction_171 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn57 - (bracket happy_var_2 - )} - -happyReduce_172 = happySpecReduce_2 51# happyReduction_172 -happyReduction_172 happy_x_2 - happy_x_1 - = case happyOut57 happy_x_2 of { happy_var_2 -> - happyIn57 - (RPure happy_var_2 - )} - -happyReduce_173 = happySpecReduce_1 51# happyReduction_173 -happyReduction_173 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenMetavar happy_var_1) -> - happyIn57 - (RMetavar happy_var_1 - )} - -happyReduce_174 = happyReduce 4# 51# happyReduction_174 -happyReduction_174 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn57 - (RMetavarPrf (UN "") happy_var_3 False - ) `HappyStk` happyRest} - -happyReduce_175 = happyReduce 4# 51# happyReduction_175 -happyReduction_175 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn57 - (RMetavarPrf (UN "") happy_var_3 True - ) `HappyStk` happyRest} - -happyReduce_176 = happyReduce 4# 51# happyReduction_176 -happyReduction_176 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn57 - (RExpVar happy_var_3 happy_var_4 happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_177 = happySpecReduce_3 51# happyReduction_177 -happyReduction_177 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut64 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn57 - (RConst happy_var_2 happy_var_3 happy_var_1 - )}}} - -happyReduce_178 = happySpecReduce_1 51# happyReduction_178 -happyReduction_178 happy_x_1 - = happyIn57 - (RRefl - ) - -happyReduce_179 = happySpecReduce_3 51# happyReduction_179 -happyReduction_179 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn57 - (RVar happy_var_2 happy_var_3 (UN "__Empty") TypeCon - )}} - -happyReduce_180 = happySpecReduce_3 51# happyReduction_180 -happyReduction_180 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn57 - (RVar happy_var_2 happy_var_3 (UN "__Unit") TypeCon - )}} - -happyReduce_181 = happySpecReduce_1 51# happyReduction_181 -happyReduction_181 happy_x_1 - = happyIn57 - (RPlaceholder - ) - -happyReduce_182 = happySpecReduce_1 51# happyReduction_182 -happyReduction_182 happy_x_1 - = case happyOut61 happy_x_1 of { happy_var_1 -> - happyIn57 - (RDo happy_var_1 - )} - -happyReduce_183 = happySpecReduce_3 51# happyReduction_183 -happyReduction_183 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn57 - (RIdiom happy_var_2 - )} - -happyReduce_184 = happyReduce 5# 51# happyReduction_184 -happyReduction_184 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut59 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn57 - (pairDesugar happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "mkPair") DataCon) happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_185 = happySpecReduce_1 51# happyReduction_185 -happyReduction_185 happy_x_1 - = case happyOut55 happy_x_1 of { happy_var_1 -> - happyIn57 - (happy_var_1 - )} - -happyReduce_186 = happySpecReduce_1 51# happyReduction_186 -happyReduction_186 happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - happyIn57 - (happy_var_1 - )} - -happyReduce_187 = happySpecReduce_1 51# happyReduction_187 -happyReduction_187 happy_x_1 - = case happyOut58 happy_x_1 of { happy_var_1 -> - happyIn57 - (happy_var_1 - )} - -happyReduce_188 = happyReduce 5# 51# happyReduction_188 -happyReduction_188 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - case happyOut60 happy_x_4 of { happy_var_4 -> - happyIn57 - (mkConsList happy_var_2 happy_var_3 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_189 = happyReduce 7# 52# happyReduction_189 -happyReduction_189 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut83 happy_x_6 of { happy_var_6 -> - case happyOut82 happy_x_7 of { happy_var_7 -> - happyIn58 - (RApp happy_var_6 happy_var_7 (RApp happy_var_6 happy_var_7 (RVar happy_var_6 happy_var_7 (UN "Exists") DataCon) happy_var_2) happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_190 = happyReduce 5# 52# happyReduction_190 -happyReduction_190 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn58 - (RApp happy_var_4 happy_var_5 (RApp happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "Exists") DataCon) RPlaceholder) happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_191 = happySpecReduce_3 53# happyReduction_191 -happyReduction_191 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn59 - (happy_var_1:happy_var_3:[] - )}} - -happyReduce_192 = happySpecReduce_3 53# happyReduction_192 -happyReduction_192 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - happyIn59 - (happy_var_1:happy_var_3 - )}} - -happyReduce_193 = happySpecReduce_0 54# happyReduction_193 -happyReduction_193 = happyIn60 - ([] - ) - -happyReduce_194 = happySpecReduce_1 54# happyReduction_194 -happyReduction_194 happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - happyIn60 - ([happy_var_1] - )} - -happyReduce_195 = happySpecReduce_3 54# happyReduction_195 -happyReduction_195 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut60 happy_x_3 of { happy_var_3 -> - happyIn60 - (happy_var_1:happy_var_3 - )}} - -happyReduce_196 = happyReduce 4# 55# happyReduction_196 -happyReduction_196 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut62 happy_x_3 of { happy_var_3 -> - happyIn61 - (happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_197 = happyReduce 10# 55# happyReduction_197 -happyReduction_197 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokenBrackName happy_var_2) -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut34 happy_x_5 of { happy_var_5 -> - case happyOut83 happy_x_6 of { happy_var_6 -> - case happyOut82 happy_x_7 of { happy_var_7 -> - case happyOut62 happy_x_9 of { happy_var_9 -> - happyIn61 - (DoBinding happy_var_6 happy_var_7 happy_var_2 happy_var_3 happy_var_5 : happy_var_9 - ) `HappyStk` happyRest}}}}}} - -happyReduce_198 = happySpecReduce_2 56# happyReduction_198 -happyReduction_198 happy_x_2 - happy_x_1 - = case happyOut63 happy_x_1 of { happy_var_1 -> - case happyOut62 happy_x_2 of { happy_var_2 -> - happyIn62 - (happy_var_1:happy_var_2 - )}} - -happyReduce_199 = happySpecReduce_1 56# happyReduction_199 -happyReduction_199 happy_x_1 - = case happyOut63 happy_x_1 of { happy_var_1 -> - happyIn62 - ([happy_var_1] - )} - -happyReduce_200 = happyReduce 7# 57# happyReduction_200 -happyReduction_200 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut48 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut83 happy_x_5 of { happy_var_5 -> - case happyOut82 happy_x_6 of { happy_var_6 -> - happyIn63 - (DoBinding happy_var_5 happy_var_6 happy_var_1 happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}}}} - -happyReduce_201 = happyReduce 8# 57# happyReduction_201 -happyReduction_201 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut34 happy_x_5 of { happy_var_5 -> - case happyOut83 happy_x_6 of { happy_var_6 -> - case happyOut82 happy_x_7 of { happy_var_7 -> - happyIn63 - (DoLet happy_var_6 happy_var_7 happy_var_2 happy_var_3 happy_var_5 - ) `HappyStk` happyRest}}}}} - -happyReduce_202 = happyReduce 4# 57# happyReduction_202 -happyReduction_202 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn63 - (DoExp happy_var_2 happy_var_3 happy_var_1 - ) `HappyStk` happyRest}}} - -happyReduce_203 = happySpecReduce_1 58# happyReduction_203 -happyReduction_203 happy_x_1 - = happyIn64 - (TYPE - ) - -happyReduce_204 = happySpecReduce_1 58# happyReduction_204 -happyReduction_204 happy_x_1 - = happyIn64 - (LTYPE - ) - -happyReduce_205 = happySpecReduce_1 58# happyReduction_205 -happyReduction_205 happy_x_1 - = happyIn64 - (StringType - ) - -happyReduce_206 = happySpecReduce_1 58# happyReduction_206 -happyReduction_206 happy_x_1 - = happyIn64 - (IntType - ) - -happyReduce_207 = happySpecReduce_1 58# happyReduction_207 -happyReduction_207 happy_x_1 - = happyIn64 - (CharType - ) - -happyReduce_208 = happySpecReduce_1 58# happyReduction_208 -happyReduction_208 happy_x_1 - = happyIn64 - (FloatType - ) - -happyReduce_209 = happySpecReduce_1 58# happyReduction_209 -happyReduction_209 happy_x_1 - = happyIn64 - (PtrType - ) - -happyReduce_210 = happySpecReduce_1 58# happyReduction_210 -happyReduction_210 happy_x_1 - = happyIn64 - (Builtin "Handle" - ) - -happyReduce_211 = happySpecReduce_1 58# happyReduction_211 -happyReduction_211 happy_x_1 - = happyIn64 - (Builtin "Lock" - ) - -happyReduce_212 = happySpecReduce_1 58# happyReduction_212 -happyReduction_212 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenInt happy_var_1) -> - happyIn64 - (Num happy_var_1 - )} - -happyReduce_213 = happySpecReduce_1 58# happyReduction_213 -happyReduction_213 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenChar happy_var_1) -> - happyIn64 - (Ch happy_var_1 - )} - -happyReduce_214 = happySpecReduce_1 58# happyReduction_214 -happyReduction_214 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenString happy_var_1) -> - happyIn64 - (Str happy_var_1 - )} - -happyReduce_215 = happySpecReduce_1 58# happyReduction_215 -happyReduction_215 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenBool happy_var_1) -> - happyIn64 - (Bo happy_var_1 - )} - -happyReduce_216 = happySpecReduce_1 58# happyReduction_216 -happyReduction_216 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenFloat happy_var_1) -> - happyIn64 - (Fl happy_var_1 - )} - -happyReduce_217 = happySpecReduce_0 59# happyReduction_217 -happyReduction_217 = happyIn65 - ([] - ) - -happyReduce_218 = happySpecReduce_2 59# happyReduction_218 -happyReduction_218 happy_x_2 - happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - case happyOut65 happy_x_2 of { happy_var_2 -> - happyIn65 - (happy_var_1:happy_var_2 - )}} - -happyReduce_219 = happyReduce 4# 60# happyReduction_219 -happyReduction_219 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut50 happy_x_2 of { happy_var_2 -> - case happyOut67 happy_x_3 of { happy_var_3 -> - happyIn66 - ((happy_var_2, happy_var_3) - ) `HappyStk` happyRest}} - -happyReduce_220 = happySpecReduce_3 60# happyReduction_220 -happyReduction_220 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn66 - ((RConst happy_var_2 happy_var_3 TYPE, []) - )}} - -happyReduce_221 = happyReduce 4# 60# happyReduction_221 -happyReduction_221 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut73 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn66 - ((mkTyParams happy_var_3 happy_var_4 happy_var_1, []) - ) `HappyStk` happyRest}}} - -happyReduce_222 = happySpecReduce_0 61# happyReduction_222 -happyReduction_222 = happyIn67 - ([] - ) - -happyReduce_223 = happyReduce 4# 61# happyReduction_223 -happyReduction_223 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut72 happy_x_3 of { happy_var_3 -> - happyIn67 - (happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_224 = happyReduce 7# 62# happyReduction_224 -happyReduction_224 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_4 of { happy_var_4 -> - case happyOut32 happy_x_6 of { happy_var_6 -> - happyIn68 - ((happy_var_4,happy_var_6) - ) `HappyStk` happyRest}} - -happyReduce_225 = happyReduce 6# 63# happyReduction_225 -happyReduction_225 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_3 of { happy_var_3 -> - case happyOut32 happy_x_5 of { happy_var_5 -> - happyIn69 - ((happy_var_3,happy_var_5) - ) `HappyStk` happyRest}} - -happyReduce_226 = happyReduce 4# 64# happyReduction_226 -happyReduction_226 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut72 happy_x_3 of { happy_var_3 -> - happyIn70 - (happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_227 = happySpecReduce_2 65# happyReduction_227 -happyReduction_227 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_2 of { happy_var_2 -> - happyIn71 - (happy_var_2 - )} - -happyReduce_228 = happySpecReduce_3 66# happyReduction_228 -happyReduction_228 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn72 - ([(happy_var_1, happy_var_3)] - )}} - -happyReduce_229 = happyReduce 5# 66# happyReduction_229 -happyReduction_229 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - case happyOut72 happy_x_5 of { happy_var_5 -> - happyIn72 - ((happy_var_1,happy_var_3):happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_230 = happySpecReduce_1 67# happyReduction_230 -happyReduction_230 happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - happyIn73 - ([happy_var_1] - )} - -happyReduce_231 = happySpecReduce_2 67# happyReduction_231 -happyReduction_231 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut73 happy_x_2 of { happy_var_2 -> - happyIn73 - (happy_var_1:happy_var_2 - )}} - -happyReduce_232 = happySpecReduce_1 68# happyReduction_232 -happyReduction_232 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn74 - (happy_var_1 - )} - -happyReduce_233 = happySpecReduce_1 68# happyReduction_233 -happyReduction_233 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn74 - (happy_var_1 - )} - -happyReduce_234 = happySpecReduce_0 69# happyReduction_234 -happyReduction_234 = happyIn75 - ([] - ) - -happyReduce_235 = happySpecReduce_1 69# happyReduction_235 -happyReduction_235 happy_x_1 - = case happyOut76 happy_x_1 of { happy_var_1 -> - happyIn75 - ([happy_var_1] - )} - -happyReduce_236 = happySpecReduce_3 69# happyReduction_236 -happyReduction_236 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut76 happy_x_1 of { happy_var_1 -> - case happyOut75 happy_x_3 of { happy_var_3 -> - happyIn75 - (happy_var_1:happy_var_3 - )}} - -happyReduce_237 = happySpecReduce_2 70# happyReduction_237 -happyReduction_237 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut77 happy_x_2 of { happy_var_2 -> - happyIn76 - (Full happy_var_1 happy_var_2 - )}} - -happyReduce_238 = happySpecReduce_2 70# happyReduction_238 -happyReduction_238 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut65 happy_x_2 of { happy_var_2 -> - happyIn76 - (Simple happy_var_1 happy_var_2 - )}} - -happyReduce_239 = happySpecReduce_2 71# happyReduction_239 -happyReduction_239 happy_x_2 - happy_x_1 - = case happyOut50 happy_x_2 of { happy_var_2 -> - happyIn77 - (happy_var_2 - )} - -happyReduce_240 = happySpecReduce_2 72# happyReduction_240 -happyReduction_240 happy_x_2 - happy_x_1 - = case happyOut38 happy_x_2 of { happy_var_2 -> - happyIn78 - (Intro happy_var_2 - )} - -happyReduce_241 = happySpecReduce_1 72# happyReduction_241 -happyReduction_241 happy_x_1 - = happyIn78 - (Intro [] - ) - -happyReduce_242 = happySpecReduce_2 72# happyReduction_242 -happyReduction_242 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_2 of { happy_var_2 -> - happyIn78 - (Refine happy_var_2 - )} - -happyReduce_243 = happySpecReduce_2 72# happyReduction_243 -happyReduction_243 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Exists happy_var_2 - )} - -happyReduce_244 = happySpecReduce_2 72# happyReduction_244 -happyReduction_244 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Generalise happy_var_2 - )} - -happyReduce_245 = happySpecReduce_1 72# happyReduction_245 -happyReduction_245 happy_x_1 - = happyIn78 - (ReflP - ) - -happyReduce_246 = happySpecReduce_2 72# happyReduction_246 -happyReduction_246 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Rewrite False False happy_var_2 - )} - -happyReduce_247 = happySpecReduce_3 72# happyReduction_247 -happyReduction_247 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn78 - (Rewrite False True happy_var_3 - )} - -happyReduce_248 = happySpecReduce_2 72# happyReduction_248 -happyReduction_248 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Rewrite True False happy_var_2 - )} - -happyReduce_249 = happySpecReduce_3 72# happyReduction_249 -happyReduction_249 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn78 - (Rewrite True True happy_var_3 - )} - -happyReduce_250 = happySpecReduce_1 72# happyReduction_250 -happyReduction_250 happy_x_1 - = happyIn78 - (Compute - ) - -happyReduce_251 = happySpecReduce_2 72# happyReduction_251 -happyReduction_251 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_2 of { happy_var_2 -> - happyIn78 - (Unfold happy_var_2 - )} - -happyReduce_252 = happySpecReduce_1 72# happyReduction_252 -happyReduction_252 happy_x_1 - = happyIn78 - (Undo - ) - -happyReduce_253 = happySpecReduce_2 72# happyReduction_253 -happyReduction_253 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Induction happy_var_2 - )} - -happyReduce_254 = happySpecReduce_2 72# happyReduction_254 -happyReduction_254 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Fill happy_var_2 - )} - -happyReduce_255 = happySpecReduce_1 72# happyReduction_255 -happyReduction_255 happy_x_1 - = happyIn78 - (Trivial - ) - -happyReduce_256 = happySpecReduce_1 72# happyReduction_256 -happyReduction_256 happy_x_1 - = happyIn78 - (SimpleSearch - ) - -happyReduce_257 = happySpecReduce_2 72# happyReduction_257 -happyReduction_257 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (RunTactic happy_var_2 - )} - -happyReduce_258 = happySpecReduce_2 72# happyReduction_258 -happyReduction_258 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Believe happy_var_2 - )} - -happyReduce_259 = happySpecReduce_2 72# happyReduction_259 -happyReduction_259 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Use happy_var_2 - )} - -happyReduce_260 = happySpecReduce_2 72# happyReduction_260 -happyReduction_260 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Decide happy_var_2 - )} - -happyReduce_261 = happySpecReduce_1 72# happyReduction_261 -happyReduction_261 happy_x_1 - = happyIn78 - (Abandon - ) - -happyReduce_262 = happySpecReduce_1 72# happyReduction_262 -happyReduction_262 happy_x_1 - = happyIn78 - (ProofTerm - ) - -happyReduce_263 = happySpecReduce_1 72# happyReduction_263 -happyReduction_263 happy_x_1 - = happyIn78 - (Qed - ) - -happyReduce_264 = happyReduce 4# 73# happyReduction_264 -happyReduction_264 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn79 - (happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_265 = happySpecReduce_2 74# happyReduction_265 -happyReduction_265 happy_x_2 - happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - happyIn80 - ([happy_var_1] - )} - -happyReduce_266 = happySpecReduce_1 74# happyReduction_266 -happyReduction_266 happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - happyIn80 - ([happy_var_1] - )} - -happyReduce_267 = happySpecReduce_3 74# happyReduction_267 -happyReduction_267 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn80 - (happy_var_1:happy_var_3 - )}} - -happyReduce_268 = happySpecReduce_1 75# happyReduction_268 -happyReduction_268 happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - happyIn81 - ([happy_var_1] - )} - -happyReduce_269 = happySpecReduce_3 75# happyReduction_269 -happyReduction_269 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn81 - (happy_var_1:happy_var_3 - )}} - -happyReduce_270 = happyMonadReduce 0# 76# happyReduction_270 -happyReduction_270 (happyRest) tk - = happyThen (( getLineNo) - ) (\r -> happyReturn (happyIn82 r)) - -happyReduce_271 = happyMonadReduce 0# 77# happyReduction_271 -happyReduction_271 (happyRest) tk - = happyThen (( getFileName) - ) (\r -> happyReturn (happyIn83 r)) - -happyReduce_272 = happyMonadReduce 0# 78# happyReduction_272 -happyReduction_272 (happyRest) tk - = happyThen (( getOps) - ) (\r -> happyReturn (happyIn84 r)) - -happyNewToken action sts stk - = lexer(\tk -> - let cont i = happyDoAction i tk action sts stk in - case tk of { - TokenEOF -> happyDoAction 125# tk action sts stk; - TokenName happy_dollar_dollar -> cont 1#; - TokenInfixName happy_dollar_dollar -> cont 2#; - TokenBrackName happy_dollar_dollar -> cont 3#; - TokenString happy_dollar_dollar -> cont 4#; - TokenInt happy_dollar_dollar -> cont 5#; - TokenFloat happy_dollar_dollar -> cont 6#; - TokenChar happy_dollar_dollar -> cont 7#; - TokenBool happy_dollar_dollar -> cont 8#; - TokenMetavar happy_dollar_dollar -> cont 9#; - TokenColon -> cont 10#; - TokenSemi -> cont 11#; - TokenBar -> cont 12#; - TokenStars -> cont 13#; - TokenLambda -> cont 14#; - TokenHashOB -> cont 15#; - TokenOB -> cont 16#; - TokenCB -> cont 17#; - TokenOCB -> cont 18#; - TokenCCB -> cont 19#; - TokenOSB -> cont 20#; - TokenCSB -> cont 21#; - TokenOId -> cont 22#; - TokenCId -> cont 23#; - TokenLPair -> cont 24#; - TokenRPair -> cont 25#; - TokenExists -> cont 26#; - TokenTilde -> cont 27#; - TokenPlus -> cont 28#; - TokenMinus -> cont 29#; - TokenTimes -> cont 30#; - TokenDivide -> cont 31#; - TokenEquals -> cont 32#; - TokenMightEqual -> cont 33#; - TokenLT -> cont 34#; - TokenGT -> cont 35#; - TokenEllipsis -> cont 36#; - TokenUnderscore -> cont 37#; - TokenComma -> cont 38#; - TokenTuple -> cont 39#; - TokenBang -> cont 40#; - TokenConcat -> cont 41#; - TokenGE -> cont 42#; - TokenLE -> cont 43#; - TokenOr -> cont 44#; - TokenAnd -> cont 45#; - TokenArrow -> cont 46#; - TokenFatArrow -> cont 47#; - TokenTransArrow -> cont 48#; - TokenLeftArrow -> cont 49#; - TokenIntType -> cont 50#; - TokenCharType -> cont 51#; - TokenFloatType -> cont 52#; - TokenStringType -> cont 53#; - TokenHandleType -> cont 54#; - TokenPtrType -> cont 55#; - TokenLockType -> cont 56#; - TokenType -> cont 57#; - TokenLType -> cont 58#; - TokenLazyBracket -> cont 59#; - TokenDataType -> cont 60#; - TokenCoDataType -> cont 61#; - TokenInfix -> cont 62#; - TokenInfixL -> cont 63#; - TokenInfixR -> cont 64#; - TokenUsing -> cont 65#; - TokenIdiom -> cont 66#; - TokenParams -> cont 67#; - TokenNamespace -> cont 68#; - TokenPublic -> cont 69#; - TokenPrivate -> cont 70#; - TokenAbstract -> cont 71#; - TokenNoElim -> cont 72#; - TokenCollapsible -> cont 73#; - TokenWhere -> cont 74#; - TokenWith -> cont 75#; - TokenPartial -> cont 76#; - TokenSyntax -> cont 77#; - TokenHide -> cont 78#; - TokenLazy -> cont 79#; - TokenStatic -> cont 80#; - TokenRefl -> cont 81#; - TokenEmptyType -> cont 82#; - TokenUnitType -> cont 83#; - TokenInclude -> cont 84#; - TokenExport -> cont 85#; - TokenInline -> cont 86#; - TokenDo -> cont 87#; - TokenReturn -> cont 88#; - TokenIf -> cont 89#; - TokenThen -> cont 90#; - TokenElse -> cont 91#; - TokenLet -> cont 92#; - TokenIn -> cont 93#; - TokenProof -> cont 94#; - TokenTryProof -> cont 95#; - TokenIntro -> cont 96#; - TokenRefine -> cont 97#; - TokenGeneralise -> cont 98#; - TokenReflP -> cont 99#; - TokenRewrite -> cont 100#; - TokenRewriteAll -> cont 101#; - TokenCompute -> cont 102#; - TokenUnfold -> cont 103#; - TokenUndo -> cont 104#; - TokenInduction -> cont 105#; - TokenFill -> cont 106#; - TokenTrivial -> cont 107#; - TokenSimpleSearch -> cont 108#; - TokenMkTac -> cont 109#; - TokenBelieve -> cont 110#; - TokenUse -> cont 111#; - TokenDecide -> cont 112#; - TokenAbandon -> cont 113#; - TokenProofTerm -> cont 114#; - TokenQED -> cont 115#; - TokenLaTeX -> cont 116#; - TokenNoCG -> cont 117#; - TokenEval -> cont 118#; - TokenSpec -> cont 119#; - TokenFreeze -> cont 120#; - TokenThaw -> cont 121#; - TokenTransform -> cont 122#; - TokenCInclude -> cont 123#; - TokenCLib -> cont 124#; - _ -> happyError' tk - }) - -happyError_ tk = happyError' tk - -happyThen :: () => P a -> (a -> P b) -> P b -happyThen = (thenP) -happyReturn :: () => a -> P a -happyReturn = (returnP) -happyThen1 = happyThen -happyReturn1 :: () => a -> P a -happyReturn1 = happyReturn -happyError' :: () => (Token) -> P a -happyError' tk = (\token -> happyError) tk - -mkparse = happySomeParser where - happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut6 x)) - -mkparseTerm = happySomeParser where - happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (happyOut34 x)) - -mkparseTactic = happySomeParser where - happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (happyOut78 x)) - -happySeq = happyDontSeq - - -data ConParse = Full Id RawTerm - | Simple Id [RawTerm] - -parse :: String -> FilePath -> Result [Decl] -parse s fn = do ds <- mkparse s fn 1 [] - collectDecls ds - -processImports :: [Opt] -> [FilePath] -> Result [Decl] -> - IO ([Decl], [FilePath]) -processImports opts imped (Success ds) = pi imped [] ds - where pi imps decls ((PInclude fp):xs) - | fp `elem` imps = pi imps decls xs - | otherwise = do - f <- readLibFile defaultLibPath fp - when (Verbose `elem` opts) $ putStrLn ("Reading " ++ fp) - case parse f fp of - Success t -> pi (fp:imps) decls (t++xs) - Failure e f l -> - fail $ f ++ ":" ++ show l ++ ":" ++ e - pi imps decls ((Using t ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[Using t ds']) xs - pi imps decls ((Params t ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[Params t ds']) xs - pi imps decls ((DoUsing b r ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[DoUsing b r ds']) xs - pi imps decls ((Idiom b r ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[Idiom b r ds']) xs - pi imps decls ((Namespace n ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[Namespace n ds']) xs - pi imps decls (x:xs) = pi imps (decls++[x]) xs - pi imps decls [] = return (decls, imps) - -processImports _ imped (Failure e f l) - = fail $ show f ++ ":" ++ show l ++ ":" ++ show e - - -parseTerm :: String -> Result RawTerm -parseTerm s = mkparseTerm s "(input)" 0 [] - -parseTactic :: String -> Result ITactic -parseTactic s = mkparseTactic s "(tactic)" 0 [] - --- Make a constructor type, and make arguments lazy if it's codata - -mkCon :: Bool -> RawTerm -> ConParse -> (Id,RawTerm) -mkCon co _ (Full n t) = (n,if co then lazify t else t) -mkCon co ty (Simple n args) = (n, mkConTy args ty) - where mkConTy [] ty = ty - mkConTy (a:as) ty = let opts = if co then [Lazy] else [] in - RBind (MN "X" 0) (Pi Ex opts a) (mkConTy as ty) - --- Make sure all arguments are lazy - -lazify :: RawTerm -> RawTerm -lazify (RBind n (Pi p opts a) sc) - = RBind n (Pi p (nub (Lazy:opts)) a) (lazify sc) -lazify t = t - -mkDef file line (n, tms) = mkImpApp (RVar file line n Unknown) tms - where mkImpApp f [] = f - mkImpApp f ((tm,Just n):ts) = mkImpApp (RAppImp file line n f tm) ts - mkImpApp f ((tm, Nothing):ts) = mkImpApp (RApp file line f tm) ts - -doBind :: (RawTerm -> RBinder) -> [(Id,RawTerm)] -> RawTerm -> RawTerm -doBind b [] t = t -doBind b ((x,ty):ts) tm = RBind x (b ty) (doBind b ts tm) - -doLetBind :: [(Id,RawTerm,RawTerm)] -> RawTerm -> RawTerm -doLetBind [] t = t -doLetBind ((x,ty,val):ts) tm = RBind x (RLet val ty) (doLetBind ts tm) - -mkTyApp :: String -> Int -> Id -> RawTerm -> RawTerm -mkTyApp file line n ty = mkApp file line (RVar file line n Unknown) (getTyArgs ty) - where getTyArgs (RBind n _ t) = (RVar file line n Unknown):(getTyArgs t) - getTyArgs x = [] - -mkTyParams :: String -> Int -> [Id] -> RawTerm -mkTyParams f l [] = RConst f l TYPE -mkTyParams f l (x:xs) = RBind x (Pi Ex [] (RConst f l TYPE)) (mkTyParams f l xs) - -mkDatatype :: Bool -> String -> Int -> - Id -> Either RawTerm ((RawTerm, [(Id, RawTerm)]), [ConParse]) -> - [TyOpt] -> Datatype -mkDatatype co file line n (Right ((t, using), cons)) opts - = let opts' = if co then nub (Codata:opts) else opts in - Datatype n t (map (mkCon co (mkTyApp file line n t)) cons) using opts' file line -mkDatatype co file line n (Left t) opts - = Latatype n t file line - -bracket (RUserInfix f l _ op x y) = RUserInfix f l True op x y -bracket x = x - -pairDesugar :: String -> Int -> RawTerm -> [RawTerm] -> RawTerm -pairDesugar file line pair [x,y] = mkApp file line pair [x,y] -pairDesugar file line pair (x:y:xs) - = pairDesugar file line pair ((mkApp file line pair [x,y]):xs) - -sigDesugar :: String -> Int -> (Id, RawTerm) -> RawTerm -> RawTerm -sigDesugar file line (n, tm) sc - = mkApp file line (RVar file line (UN "Sigma") TypeCon) [tm, lam] - where lam = RBind n (Lam tm) sc - -mkConsList :: String -> Int -> [RawTerm] -> RawTerm -mkConsList f l [] = RVar f l (UN "Nil") Unknown -mkConsList f l (x:xs) = RApp f l (RApp f l (RVar f l (UN "Cons") Unknown) x) - (mkConsList f l xs) - -mkhidden (UN n) = MN (n++" is hidden") 0 -{-# 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" #-} - - -data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList - - - - - -{-# 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 0#, 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 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where !(new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where !(off) = indexShortOffAddr happyActOffsets st - !(off_i) = (off Happy_GHC_Exts.+# i) - check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) - then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) - else False - !(action) - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - -{-# LINE 130 "templates/GenericTemplate.hs" #-} - - -indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i - where - !i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - !high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - !low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - !off' = off Happy_GHC_Exts.*# 2# - - - - - -data HappyAddr = HappyA# Happy_GHC_Exts.Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - -{-# LINE 163 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let !(i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# 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@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - - !(off) = indexShortOffAddr happyGotoOffsets st1 - !(off_i) = (off Happy_GHC_Exts.+# nt) - !(new_state) = indexShortOffAddr happyTable off_i - - - - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where !(off) = indexShortOffAddr happyGotoOffsets st - !(off_i) = (off Happy_GHC_Exts.+# nt) - !(new_state) = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# 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 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- 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. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# 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/dist/build/Idris/idris-tmp/Idris/Parser.hs b/dist/build/Idris/idris-tmp/Idris/Parser.hs deleted file mode 100644 --- a/dist/build/Idris/idris-tmp/Idris/Parser.hs +++ /dev/null @@ -1,3973 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -{-# OPTIONS -fglasgow-exts -cpp #-} --- -*-Haskell-*- -{-# OPTIONS_GHC -fglasgow-exts #-} - -module Idris.Parser where - -import Data.Char -import Ivor.TT -import System.IO.Unsafe -import List -import Control.Monad - -import Idris.AbsSyntax -import Idris.Lexer -import Idris.Lib - -import Debug.Trace -import qualified Data.Array as Happy_Data_Array -import qualified GHC.Exts as Happy_GHC_Exts - --- parser produced by Happy Version 1.18.5 - -newtype HappyAbsSyn t74 = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn6 :: ([ParseDecl]) -> (HappyAbsSyn t74) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn t74) -> ([ParseDecl]) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (ParseDecl) -> (HappyAbsSyn t74) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn t74) -> (ParseDecl) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (Decl) -> (HappyAbsSyn t74) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn t74) -> (Decl) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (ParseDecl) -> (HappyAbsSyn t74) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn t74) -> (ParseDecl) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: (CGFlag) -> (HappyAbsSyn t74) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn t74) -> (CGFlag) -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (Bool) -> (HappyAbsSyn t74) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn t74) -> (Bool) -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: ([RawTerm]) -> (HappyAbsSyn t74) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn t74) -> ([RawTerm]) -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: ([ParseDecl]) -> (HappyAbsSyn t74) -happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn t74) -> ([ParseDecl]) -happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: ([CGFlag]) -> (HappyAbsSyn t74) -happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn t74) -> ([CGFlag]) -happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: ([CGFlag]) -> (HappyAbsSyn t74) -happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn t74) -> ([CGFlag]) -happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: ([CGFlag]) -> (HappyAbsSyn t74) -happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn t74) -> ([CGFlag]) -happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyIn18 :: ([Decl]) -> (HappyAbsSyn t74) -happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn t74) -> ([Decl]) -happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut18 #-} -happyIn19 :: ([String]) -> (HappyAbsSyn t74) -happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn t74) -> ([String]) -happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut19 #-} -happyIn20 :: (String) -> (HappyAbsSyn t74) -happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn t74) -> (String) -happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut20 #-} -happyIn21 :: (Fixity) -> (HappyAbsSyn t74) -happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn t74) -> (Fixity) -happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut21 #-} -happyIn22 :: (Decl) -> (HappyAbsSyn t74) -happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn t74) -> (Decl) -happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut22 #-} -happyIn23 :: ([(Id,String)]) -> (HappyAbsSyn t74) -happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn t74) -> ([(Id,String)]) -happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut23 #-} -happyIn24 :: ((Id, [(RawTerm, Maybe Id)])) -> (HappyAbsSyn t74) -happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn t74) -> ((Id, [(RawTerm, Maybe Id)])) -happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut24 #-} -happyIn25 :: ([(RawTerm,Maybe Id)]) -> (HappyAbsSyn t74) -happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn t74) -> ([(RawTerm,Maybe Id)]) -happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut25 #-} -happyIn26 :: (Datatype) -> (HappyAbsSyn t74) -happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn t74) -> (Datatype) -happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut26 #-} -happyIn27 :: (Bool) -> (HappyAbsSyn t74) -happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn t74) -> (Bool) -happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut27 #-} -happyIn28 :: (Either RawTerm ((RawTerm, [(Id, RawTerm)]), [ConParse])) -> (HappyAbsSyn t74) -happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn t74) -> (Either RawTerm ((RawTerm, [(Id, RawTerm)]), [ConParse])) -happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut28 #-} -happyIn29 :: ([TyOpt]) -> (HappyAbsSyn t74) -happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn t74) -> ([TyOpt]) -happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut29 #-} -happyIn30 :: ([TyOpt]) -> (HappyAbsSyn t74) -happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn t74) -> ([TyOpt]) -happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut30 #-} -happyIn31 :: (TyOpt) -> (HappyAbsSyn t74) -happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn t74) -> (TyOpt) -happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut31 #-} -happyIn32 :: (Id) -> (HappyAbsSyn t74) -happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn t74) -> (Id) -happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut32 #-} -happyIn33 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut33 #-} -happyIn34 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut34 #-} -happyIn35 :: ([(Id, RawTerm)]) -> (HappyAbsSyn t74) -happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn t74) -> ([(Id, RawTerm)]) -happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut35 #-} -happyIn36 :: ([(Id, RawTerm)]) -> (HappyAbsSyn t74) -happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn t74) -> ([(Id, RawTerm)]) -happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut36 #-} -happyIn37 :: ([(Id, RawTerm)]) -> (HappyAbsSyn t74) -happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn t74) -> ([(Id, RawTerm)]) -happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut37 #-} -happyIn38 :: ([Id]) -> (HappyAbsSyn t74) -happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn t74) -> ([Id]) -happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut38 #-} -happyIn39 :: ([(Id, Int)]) -> (HappyAbsSyn t74) -happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn t74) -> ([(Id, Int)]) -happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut39 #-} -happyIn40 :: ([Id]) -> (HappyAbsSyn t74) -happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn t74) -> ([Id]) -happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut40 #-} -happyIn41 :: ([Id]) -> (HappyAbsSyn t74) -happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn t74) -> ([Id]) -happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut41 #-} -happyIn42 :: ([(Id, RawTerm, RawTerm)]) -> (HappyAbsSyn t74) -happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn t74) -> ([(Id, RawTerm, RawTerm)]) -happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut42 #-} -happyIn43 :: ((Id, RawTerm)) -> (HappyAbsSyn t74) -happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn t74) -> ((Id, RawTerm)) -happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut43 #-} -happyIn44 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut44 #-} -happyIn45 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut45 #-} -happyIn46 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut46 #-} -happyIn47 :: (String) -> (HappyAbsSyn t74) -happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn t74) -> (String) -happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut47 #-} -happyIn48 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut48 #-} -happyIn49 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut49 #-} -happyIn50 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut50 #-} -happyIn51 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn51 #-} -happyOut51 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut51 #-} -happyIn52 :: (ArgOpt) -> (HappyAbsSyn t74) -happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn52 #-} -happyOut52 :: (HappyAbsSyn t74) -> (ArgOpt) -happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut52 #-} -happyIn53 :: ([ArgOpt]) -> (HappyAbsSyn t74) -happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn53 #-} -happyOut53 :: (HappyAbsSyn t74) -> ([ArgOpt]) -happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut53 #-} -happyIn54 :: ([ArgOpt]) -> (HappyAbsSyn t74) -happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn54 #-} -happyOut54 :: (HappyAbsSyn t74) -> ([ArgOpt]) -happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut54 #-} -happyIn55 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn55 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn55 #-} -happyOut55 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut55 #-} -happyIn56 :: ([RawTerm]) -> (HappyAbsSyn t74) -happyIn56 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn56 #-} -happyOut56 :: (HappyAbsSyn t74) -> ([RawTerm]) -happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut56 #-} -happyIn57 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn57 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn57 #-} -happyOut57 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut57 #-} -happyIn58 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn58 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn58 #-} -happyOut58 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut58 #-} -happyIn59 :: ([RawTerm]) -> (HappyAbsSyn t74) -happyIn59 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn59 #-} -happyOut59 :: (HappyAbsSyn t74) -> ([RawTerm]) -happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut59 #-} -happyIn60 :: ([RawTerm]) -> (HappyAbsSyn t74) -happyIn60 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn60 #-} -happyOut60 :: (HappyAbsSyn t74) -> ([RawTerm]) -happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut60 #-} -happyIn61 :: ([Do]) -> (HappyAbsSyn t74) -happyIn61 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn61 #-} -happyOut61 :: (HappyAbsSyn t74) -> ([Do]) -happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut61 #-} -happyIn62 :: ([Do]) -> (HappyAbsSyn t74) -happyIn62 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn62 #-} -happyOut62 :: (HappyAbsSyn t74) -> ([Do]) -happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut62 #-} -happyIn63 :: (Do) -> (HappyAbsSyn t74) -happyIn63 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn63 #-} -happyOut63 :: (HappyAbsSyn t74) -> (Do) -happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut63 #-} -happyIn64 :: (Constant) -> (HappyAbsSyn t74) -happyIn64 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn64 #-} -happyOut64 :: (HappyAbsSyn t74) -> (Constant) -happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut64 #-} -happyIn65 :: ([RawTerm]) -> (HappyAbsSyn t74) -happyIn65 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn65 #-} -happyOut65 :: (HappyAbsSyn t74) -> ([RawTerm]) -happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut65 #-} -happyIn66 :: ((RawTerm, [(Id, RawTerm)])) -> (HappyAbsSyn t74) -happyIn66 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn66 #-} -happyOut66 :: (HappyAbsSyn t74) -> ((RawTerm, [(Id, RawTerm)])) -happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut66 #-} -happyIn67 :: ([(Id, RawTerm)]) -> (HappyAbsSyn t74) -happyIn67 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn67 #-} -happyOut67 :: (HappyAbsSyn t74) -> ([(Id, RawTerm)]) -happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut67 #-} -happyIn68 :: ((Id,Id)) -> (HappyAbsSyn t74) -happyIn68 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn68 #-} -happyOut68 :: (HappyAbsSyn t74) -> ((Id,Id)) -happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut68 #-} -happyIn69 :: ((Id,Id)) -> (HappyAbsSyn t74) -happyIn69 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn69 #-} -happyOut69 :: (HappyAbsSyn t74) -> ((Id,Id)) -happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut69 #-} -happyIn70 :: ([(Id, RawTerm)]) -> (HappyAbsSyn t74) -happyIn70 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn70 #-} -happyOut70 :: (HappyAbsSyn t74) -> ([(Id, RawTerm)]) -happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut70 #-} -happyIn71 :: (Id) -> (HappyAbsSyn t74) -happyIn71 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn71 #-} -happyOut71 :: (HappyAbsSyn t74) -> (Id) -happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut71 #-} -happyIn72 :: ([(Id, RawTerm)]) -> (HappyAbsSyn t74) -happyIn72 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn72 #-} -happyOut72 :: (HappyAbsSyn t74) -> ([(Id, RawTerm)]) -happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut72 #-} -happyIn73 :: ([Id]) -> (HappyAbsSyn t74) -happyIn73 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn73 #-} -happyOut73 :: (HappyAbsSyn t74) -> ([Id]) -happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut73 #-} -happyIn74 :: t74 -> (HappyAbsSyn t74) -happyIn74 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn74 #-} -happyOut74 :: (HappyAbsSyn t74) -> t74 -happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut74 #-} -happyIn75 :: ([ConParse]) -> (HappyAbsSyn t74) -happyIn75 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn75 #-} -happyOut75 :: (HappyAbsSyn t74) -> ([ConParse]) -happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut75 #-} -happyIn76 :: (ConParse) -> (HappyAbsSyn t74) -happyIn76 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn76 #-} -happyOut76 :: (HappyAbsSyn t74) -> (ConParse) -happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut76 #-} -happyIn77 :: (RawTerm) -> (HappyAbsSyn t74) -happyIn77 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn77 #-} -happyOut77 :: (HappyAbsSyn t74) -> (RawTerm) -happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut77 #-} -happyIn78 :: (ITactic) -> (HappyAbsSyn t74) -happyIn78 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn78 #-} -happyOut78 :: (HappyAbsSyn t74) -> (ITactic) -happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut78 #-} -happyIn79 :: ([ITactic]) -> (HappyAbsSyn t74) -happyIn79 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn79 #-} -happyOut79 :: (HappyAbsSyn t74) -> ([ITactic]) -happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut79 #-} -happyIn80 :: ([ITactic]) -> (HappyAbsSyn t74) -happyIn80 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn80 #-} -happyOut80 :: (HappyAbsSyn t74) -> ([ITactic]) -happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut80 #-} -happyIn81 :: ([ITactic]) -> (HappyAbsSyn t74) -happyIn81 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn81 #-} -happyOut81 :: (HappyAbsSyn t74) -> ([ITactic]) -happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut81 #-} -happyIn82 :: (LineNumber) -> (HappyAbsSyn t74) -happyIn82 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn82 #-} -happyOut82 :: (HappyAbsSyn t74) -> (LineNumber) -happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut82 #-} -happyIn83 :: (String) -> (HappyAbsSyn t74) -happyIn83 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn83 #-} -happyOut83 :: (HappyAbsSyn t74) -> (String) -happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut83 #-} -happyIn84 :: (Fixities) -> (HappyAbsSyn t74) -happyIn84 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn84 #-} -happyOut84 :: (HappyAbsSyn t74) -> (Fixities) -happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut84 #-} -happyInTok :: (Token) -> (HappyAbsSyn t74) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn t74) -> (Token) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x1d\x00\x5e\x05\x18\x02\x00\x00\x49\x04\x5e\x05\x37\x01\x37\x01\x5e\x05\x00\x00\x48\x03\xef\x02\x00\x00\x37\x01\x00\x00\x5e\x05\x5e\x05\x00\x00\x00\x00\x5e\x05\x5e\x05\x5e\x05\x5e\x05\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x01\x91\x09\x3d\x02\xc3\x01\x5e\x05\x5e\x05\xae\x08\x5e\x05\x00\x00\x37\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x05\x00\x00\x00\x00\x00\x00\xfc\x00\x00\x00\x5e\x05\x02\x01\x48\x04\x01\x00\x00\x00\x00\x00\x01\x00\xbc\x04\x00\x00\xa2\x04\x00\x00\x87\x04\xe2\x01\xab\x04\xa6\x04\xa5\x04\xa4\x04\x97\x04\x08\x0a\x75\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x04\x88\x04\x84\x04\x02\x01\x02\x01\x02\x01\x8e\x04\x54\x04\x7f\x04\x8f\x04\x5e\x05\x8b\x04\x8a\x04\x00\x00\x00\x00\xbd\x02\x00\x00\x02\x01\x72\x04\x75\x04\x00\x00\x02\x01\x00\x00\x02\x01\x02\x01\x02\x01\x70\x04\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x02\x00\x00\x00\x00\x00\x96\x02\x00\x00\x00\x00\x00\x00\x63\x00\x63\x00\x63\x00\x63\x00\x63\x00\x00\x00\x69\x08\x74\x04\x50\x01\x91\x09\x68\x04\x02\x01\xdc\x01\x5f\x00\x08\x0a\x75\x01\x00\x00\x00\x00\x6f\x04\x16\x04\x0e\x03\x00\x00\x6d\x04\x05\x05\x00\x00\x00\x00\x6c\x04\x00\x00\x6c\x04\x00\x00\x7a\x04\x6f\x03\x00\x00\x18\x02\x18\x02\xb8\x01\x1a\x04\xac\x04\x65\x04\xac\x04\xac\x04\x63\x04\x61\x04\xac\x04\xac\x04\x26\x0a\x62\x04\x59\x04\x1e\x00\x00\x00\x47\x04\xac\x04\x56\x09\x02\x01\x5e\x04\x37\x04\x00\x00\xae\x08\x51\x04\x00\x00\xac\x04\x45\x04\xac\x04\xac\x04\xac\x04\xac\x04\xac\x04\x00\x00\xa6\x01\x91\x01\x7c\x01\x67\x01\x52\x01\x3d\x01\x00\x00\x28\x01\xac\x04\x13\x01\xac\x04\xfe\x00\x00\x00\x3a\x04\x00\x00\xe9\x00\x02\x01\xc7\x00\x65\x00\x00\x00\x5a\x04\x5a\x04\x5a\x04\x5a\x04\x5a\x04\x00\x00\xac\x04\x5a\x04\xae\x08\x00\x00\x00\x00\x00\x00\xac\x04\x2f\x04\xcc\x09\x46\x04\x3e\x04\x28\x04\xa5\x01\x39\x04\x8b\x00\x36\x04\x53\x09\x02\x01\xcc\x09\xcc\x09\xcc\x09\x00\x00\x32\x04\xcc\x09\x31\x04\x00\x00\xd8\x05\x00\x00\xd8\x05\x00\x00\xd8\x05\x00\x00\xd8\x05\x00\x00\xac\x04\x00\x00\xac\x04\xac\x04\xac\x04\xac\x04\xac\x04\x2b\x04\x38\x04\x2d\x04\x24\x04\xac\x04\x00\x00\x00\x00\xac\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\xd8\x05\x23\x04\x53\x04\x02\x01\xf6\x03\x00\x00\xfa\x03\xfa\x03\x08\x04\x1b\x04\x04\x04\x19\x04\xfa\x03\xfa\x03\xfa\x03\xc6\x03\x0c\x04\xfd\x03\x00\x00\x00\x00\xd3\x05\x18\x02\x15\x04\x69\x08\xfa\x03\x00\x00\x00\x00\x0b\x04\x06\x04\x05\x04\x03\x04\x01\x04\x00\x00\x00\x00\x18\x04\x02\x04\x00\x00\x00\x00\xfa\x03\xfa\x03\xfa\x03\x00\x00\x07\x04\xfe\x03\xe6\x03\xfc\x03\x02\x01\xeb\x03\x00\x00\x01\x00\x02\x01\xf4\x03\xe5\x03\x00\x00\xfa\x03\x7e\x05\xfb\x03\x00\x04\x00\x00\xd6\x03\x00\x00\xec\x03\xfa\x03\x00\x00\x00\x00\x02\x01\x00\x00\x91\x09\x25\x05\xcc\x04\x7c\x05\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x05\x00\x00\xe1\x03\xd5\x03\x00\x00\x02\x01\x02\x01\xd1\x03\x91\x09\x00\x00\x00\x00\xdc\x01\x00\x00\x00\x00\xca\x04\x9c\x04\x91\x03\x00\x00\x75\x01\x00\x00\xfa\x03\xaa\x00\xb4\x02\xfa\x03\xda\x03\x00\x00\x00\x00\x00\x00\xb8\x03\x1a\x09\x00\x00\xf3\x08\x16\x03\x00\x00\xc8\x03\xd2\x03\x00\x00\x00\x00\x18\x02\xcc\x09\x00\x00\x67\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x03\x00\x00\xcd\x03\x00\x00\xae\x08\x00\x00\x1e\x00\xa3\x03\xa2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x09\xcc\x09\xbb\x03\x91\x09\x02\x01\x95\x03\x91\x09\x1e\x00\x02\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x08\xf3\x08\xf3\x08\xf3\x08\xf3\x08\xf3\x08\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x09\x00\x00\xd4\x00\x8c\x03\xd0\x01\x0a\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x91\x09\x00\x00\x00\x00\x24\x08\x00\x00\xdf\x07\x00\x00\x9a\x07\x00\x00\x55\x07\xbd\x03\xb7\x03\xb6\x03\xb4\x03\xb3\x03\x55\x00\x00\x00\x00\x00\xfa\x03\x00\x00\x00\x00\xfa\x03\x10\x07\xa0\x03\xd8\x05\xfa\x03\xde\x01\x00\x00\x46\x00\xa9\x03\xa7\x03\x00\x00\x00\x00\x00\x00\xf8\xff\x00\x00\xcb\x06\xab\x03\xa6\x03\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x01\x00\x00\x86\x06\x00\x00\x46\x00\x00\x00\x99\x03\x86\x03\x9a\x03\x38\x03\x00\x00\x02\x01\x76\x03\x00\x00\x00\x00\x02\x01\x8d\x03\x00\x00\x00\x00\x02\x01\x02\x01\x46\x00\x7d\x03\x00\x00\x00\x00\x00\x00\x83\x03\xd9\x01\x8b\x03\x00\x00\x00\x00\x00\x00\x7b\x03\x00\x00\x00\x00\x02\x01\x00\x00\xae\x08\x00\x00\x00\x00\x91\x09\x00\x00\x3e\x03\x00\x00\x00\x00\x00\x00\x02\x01\x00\x00\x74\x03\x02\x01\x82\x03\x00\x00\xfa\x03\x00\x00\xd8\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x03\x61\x03\x00\x00\x00\x00\xcc\x09\x49\x03\x49\x03\x00\x00\xd0\x01\x62\x03\x00\x00\x00\x00\x00\x00\xde\x01\x41\x06\x00\x00\x00\x00\x00\x00\x00\x00\x60\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x03\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\x5e\x03\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x03\x00\x00\xfc\x05\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x05\x5b\x03\x00\x00\x00\x00\x00\x00\x3c\x03\x02\x01\x00\x00\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\xf6\x0a\x55\x10\x24\x03\x00\x00\x00\x00\x3f\x10\x96\x01\x51\x03\x29\x10\x00\x00\x13\x10\xfd\x0f\x00\x00\x47\x03\x00\x00\xe7\x0f\xd1\x0f\x00\x00\x00\x00\xbb\x0f\xa5\x0f\x8f\x0f\x79\x0f\x00\x00\x00\x00\x00\x00\x1a\x03\x39\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\xb7\x0c\x77\x0b\x10\x03\x63\x0f\x4d\x0f\x9e\x10\x37\x0f\x00\x00\x3f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x0f\x00\x00\x07\x03\x06\x03\x00\x00\x05\x03\x0b\x0f\x59\x01\x00\x00\xdb\x0a\x00\x00\x00\x00\xd4\x0a\x00\x00\x00\x00\x44\x03\x00\x00\x2e\x03\x8d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x31\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x03\x1c\x03\x14\x03\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x39\x01\xe7\x02\x08\x01\x00\x00\x00\x00\xe5\x02\x68\x01\x00\x00\x41\x01\x13\x03\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x03\xdd\x02\x29\x01\x00\x00\xd2\x02\x7f\x0b\x00\x00\xd1\x02\xd0\x02\xbe\x0a\x88\x0a\x72\x0a\x6b\x0a\x50\x0a\x00\x00\xf9\x06\x00\x00\x00\x00\x8b\x0c\x00\x00\x02\x03\xea\x01\x15\x03\x94\x00\xe0\x01\x00\x00\x00\x00\xec\x02\x00\x00\x24\x01\xc9\x02\xdf\x02\xc7\x0b\xc7\x02\xbf\x02\x21\x01\xc0\x02\x14\x01\x00\x00\x0f\x01\x0f\x01\xbc\x02\xc9\x01\xc5\x01\x2a\x00\xdf\xff\xdf\x0e\x00\x00\xc9\x0e\xb3\x0e\x00\x00\x00\x00\x4f\x0b\x4a\x0b\x0c\x01\xdb\x02\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x0e\xa7\x02\xb4\x01\xda\x02\x00\x00\xb6\x02\x8d\x10\x00\x00\xb5\x02\x87\x0e\xb3\x02\x71\x0e\x5b\x0e\x45\x0e\x2f\x0e\x19\x0e\xae\x02\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x00\x00\x0a\x01\x03\x0e\x0a\x01\xed\x0d\x0a\x01\x00\x00\x00\x00\x00\x00\x0a\x01\x81\x01\x0a\x01\x0a\x01\x00\x00\x04\x01\xff\x00\xef\x00\xe5\x00\xd6\x00\xad\x02\xd7\x0d\xd2\x00\x80\x10\xa4\x02\x9d\x02\x00\x00\xc1\x0d\x00\x00\x26\x07\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x33\x01\x9c\x06\x57\x06\x99\x05\x00\x00\x00\x00\x69\x04\x00\x00\x9a\x02\xcb\x00\x97\x02\xc2\x00\x92\x02\xbb\x00\x90\x02\xb0\x00\x8f\x02\x2b\x0b\x00\x00\x26\x0b\xab\x0d\x95\x0d\x88\x09\x07\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x09\x0c\x00\x00\x88\x02\x7f\x0d\x87\x02\x86\x02\x7b\x02\x00\x00\x00\x00\xfc\xff\x99\x00\x00\x00\xb1\x0b\x3e\x01\x00\x00\x00\x00\x69\x0d\x53\x0d\x00\x00\x00\x00\x00\x00\xbe\x02\x3d\x0d\x27\x0d\x11\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\xc1\x01\x00\x00\xb4\x06\xfb\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x02\x71\x02\x79\x00\x00\x00\x70\x02\x68\x02\xe5\x0c\xcf\x0c\xb9\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x64\x02\xd6\x09\x95\x02\x00\x00\x00\x00\x61\x02\xa3\x0c\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x0c\x00\x00\x00\x00\x91\x02\x00\x00\x5f\x0c\x79\x00\x79\x00\x79\x00\x00\x00\x00\x00\x5c\x02\x00\x00\xf3\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x5a\x02\x99\x02\x00\x00\x54\x02\x4f\x00\xef\xff\x00\x00\x33\x0c\x53\x02\x17\x02\xa4\x01\x00\x00\x00\x00\x79\x00\x79\x00\x79\x00\x00\x00\x35\x01\x00\x00\x77\x0c\x79\x00\x79\x00\x61\x0c\x02\x02\x00\x00\x00\x00\x47\x02\x00\x00\x78\x10\x00\x00\x78\x10\x79\x00\x46\x02\x79\x00\x00\x00\x00\x00\x00\x00\xbe\x01\x44\x04\x45\x02\x79\x00\x00\x00\x41\x02\x22\x02\x21\x02\x20\x02\x1e\x02\x1c\x02\x1b\x02\x00\x00\x1a\x02\x00\x00\x12\x02\x6b\x10\x10\x02\x00\x00\x00\x00\x00\x00\x0f\x02\x0e\x02\x00\x00\x00\x00\x0c\x02\x00\x00\xb2\x03\xc2\x01\x07\x02\x07\x0c\x4e\x01\x00\x00\xdb\x0b\x00\x00\x2e\x00\x79\x00\x0a\x02\x08\x02\x00\x00\xfe\x01\x79\x00\x00\x00\xfd\x01\xfc\x01\xfb\x01\xf0\x01\xec\x01\x00\x00\x5a\x10\x5a\x10\x5a\x10\x5a\x10\x5a\x10\x5a\x10\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x02\x00\x00\x00\x00\x00\x00\xaa\x01\x00\x00\x00\x00\xdb\x01\xeb\x01\xdf\x01\xd1\x01\xf0\x09\xc6\x01\x00\x00\x50\x10\x00\x00\x50\x10\x00\x00\x50\x10\x00\x00\x50\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x0b\x00\x00\x95\x01\x4b\x0c\x50\x10\x00\x00\x78\x00\x35\x0c\x6b\x00\x00\x00\xa0\x02\xe7\x01\x00\x00\x00\x00\xb3\x01\xab\x01\x9e\x01\x8c\x01\xf6\x01\x00\x00\x00\x00\x00\x00\x89\x01\x00\x00\x6a\x01\x23\x01\x85\x01\x2a\x06\x7e\x01\x4f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x93\x01\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x71\x00\x73\x01\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x01\x00\x00\xed\xff\x00\x00\x97\x08\x00\x00\x00\x00\x02\x09\x4a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x01\xc0\x00\x00\x00\xd5\x00\x5c\x00\x9c\x00\x1f\x0c\x00\x00\x47\x00\x95\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x01\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\x7f\x00\x00\x00\x4a\x00\x21\x00\xdc\x08\x38\x00\x00\x00\x20\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\xd0\xff\xdc\x08\x9b\x0b\xcb\xff\xdc\x08\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x08\x00\x00\x00\x00\xc6\xff\x00\x00\x00\x00\x1d\x01\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x21\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\xff\x00\x00\x00\x00\x0a\xff\x00\x00\x00\x00\x05\xff\x00\x00\x03\xff\x00\x00\x00\x00\x00\xff\xff\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xfe\xf9\xfe\xf8\xfe\xf0\xfe\xf0\xfe\x9b\xff\x80\xff\x45\xff\x46\xff\xa2\xff\x44\xff\x49\xff\xf0\xfe\xab\xff\x29\xff\x2b\xff\x27\xff\x2a\xff\x28\xff\x52\xff\x00\x00\x00\x00\x00\x00\xf0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x4a\xff\x00\x00\x31\xff\x30\xff\x2f\xff\x32\xff\x2d\xff\x2e\xff\x2c\xff\x34\xff\x33\xff\x00\x00\x4d\xff\xf0\xfe\xf0\xfe\x00\x00\xf0\xfe\x00\x00\x00\x00\x00\x00\x21\xff\xef\xff\xf8\xff\x21\xff\x00\x00\xf6\xff\xda\xff\xf7\xff\xb1\xff\xbb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\xff\xb5\xff\xc0\xff\xc2\xff\xc1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xff\xec\xff\xf0\xfe\xf0\xfe\x00\x00\x00\x00\x00\x00\xf0\xfe\x8c\xff\x1c\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xff\xc5\xff\xc4\xff\xc3\xff\x00\x00\xf0\xfe\xf0\xfe\xd8\xff\xf0\xfe\x00\x00\xa5\xff\xf0\xfe\xf0\xfe\x21\xff\x21\xff\x21\xff\x21\xff\x21\xff\xbc\xff\xbb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xff\xfb\xff\x70\xff\x00\x00\xf0\xfe\xf1\xfe\x70\xff\x00\x00\xf1\xfe\xf1\xfe\xf0\xfe\xf0\xfe\xf0\xfe\x53\xff\xf0\xfe\xf0\xfe\xf1\xfe\x00\x00\x00\x00\xf0\xfe\xf0\xfe\x00\x00\x00\x00\xc6\xff\xc5\xff\x72\xff\x71\xff\xf0\xfe\xf0\xfe\xf0\xfe\x6e\xff\x00\x00\x6b\xff\x60\xff\x8e\xff\x00\x00\x00\x00\x00\x00\x70\xff\x00\x00\xf1\xfe\x00\x00\x00\x00\xf1\xfe\x00\x00\xf0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\x04\xff\xf0\xfe\x00\x00\xf0\xfe\x00\x00\xf0\xfe\x0d\xff\x94\xff\x0f\xff\xf0\xfe\x00\x00\xf0\xfe\xf0\xfe\x56\xff\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf1\xfe\x00\x00\xf0\xfe\x00\x00\xf0\xfe\xf0\xfe\x4e\xff\x00\x00\x99\xff\x00\x00\x00\x00\x00\x00\x96\xff\xf0\xfe\x00\x00\x00\x00\x00\x00\xf0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xa1\xff\x00\x00\x00\x00\x00\x00\xf1\xfe\xf0\xfe\xf1\xfe\xf0\xfe\xf1\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\xf0\xfe\x54\xff\xf0\xfe\x72\xff\x71\xff\xf0\xfe\xf0\xfe\x00\x00\xf5\xfe\x00\x00\x00\x00\x3e\xff\x48\xff\xf0\xfe\x00\x00\xf1\xfe\xf1\xfe\xf1\xfe\x4c\xff\x4b\xff\xf0\xfe\xf0\xfe\x00\x00\x38\xff\x00\x00\x00\x00\x55\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc8\xff\xda\xff\x00\x00\x00\x00\x00\x00\xdd\xff\x00\x00\xaf\xff\xad\xff\xac\xff\x00\x00\x00\x00\x00\x00\xbb\xff\x00\x00\xe8\xff\xba\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\xfe\xf1\xfe\xf0\xfe\x00\x00\xf1\xfe\xf1\xfe\x00\x00\x00\x00\x00\x00\xaa\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8c\xff\x00\x00\xf1\xfe\x21\xff\x00\x00\x00\x00\x00\x00\xf1\xfe\x00\x00\xf0\xfe\x00\x00\x00\x00\xbf\xff\x00\x00\xf9\xff\x00\x00\x00\x00\x8b\xff\x1d\xff\x00\x00\x20\xff\x00\x00\xf0\xfe\xf0\xfe\xf0\xfe\xa7\xff\xa6\xff\xf0\xfe\xd7\xff\x00\x00\xa4\xff\xa3\xff\xf0\xff\xf1\xff\xf2\xff\xf3\xff\xf4\xff\xf0\xfe\xf0\xfe\xd2\xff\x00\x00\xf0\xfe\x19\xff\x15\xff\x00\x00\x00\x00\xf0\xfe\xf0\xfe\x00\x00\xb0\xff\xdc\xff\xf0\xfe\xf0\xfe\xf0\xfe\xdb\xff\x00\x00\xc9\xff\x00\x00\xf0\xfe\xf0\xfe\x00\x00\x70\xff\x39\xff\x3b\xff\xf1\xfe\x00\x00\x9e\xff\x4f\xff\x86\xff\xf0\xfe\xf1\xfe\xf0\xfe\x00\x00\x51\xff\x50\xff\xf6\xfe\x00\x00\xf1\xfe\xf0\xfe\x3f\xff\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\x00\x00\xf1\xfe\x00\x00\xf1\xfe\x00\x00\xf0\xfe\x6d\xff\x00\x00\x6a\xff\xf0\xfe\xf0\xfe\x8d\xff\x64\xff\xf0\xfe\x67\xff\x00\x00\x00\x00\x5c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xff\x00\x00\xf0\xfe\xf1\xfe\xf1\xfe\xa0\xff\xf1\xfe\xf0\xfe\x88\xff\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\x93\xff\x81\xff\x84\xff\x82\xff\x83\xff\x85\xff\x7e\xff\x9f\xff\x7f\xff\x98\xff\x95\xff\x00\x00\x97\xff\x6f\xff\x00\x00\x00\x00\x58\xff\x57\xff\xf0\xfe\xf1\xfe\xf1\xfe\xf1\xfe\x00\x00\xf1\xfe\xa9\xff\x00\x00\x76\xff\x00\x00\x75\xff\x00\x00\x47\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xfe\x43\xff\x3e\xff\x41\xff\xf0\xfe\x00\x00\x00\x00\x00\x00\xf0\xfe\x00\x00\xf0\xfe\xc7\xff\x00\x00\xd2\xff\x00\x00\xae\xff\xf1\xfe\xf1\xfe\x21\xff\xf0\xfe\x26\xff\x00\x00\x14\xff\x18\xff\xf1\xfe\xf7\xfe\xf0\xfe\xd1\xff\xf1\xfe\xbb\xff\xf1\xfe\x00\x00\xe4\xff\x00\x00\x1b\xff\x00\x00\xf0\xfe\xed\xff\x00\x00\xbe\xff\xf5\xff\xea\xff\x00\x00\x00\x00\xee\xff\x1e\xff\x00\x00\x00\x00\xd4\xff\x00\x00\xd6\xff\xb8\xff\xb9\xff\x00\x00\xd1\xff\x00\x00\xcb\xff\xcf\xff\xce\xff\xcc\xff\xf1\xfe\xb7\xff\x15\xff\xb4\xff\x26\xff\x11\xff\x12\xff\x00\x00\xf1\xfe\x00\x00\xb3\xff\xb2\xff\x23\xff\x00\x00\xf0\xfe\x00\x00\x00\x00\xf0\xfe\xf1\xfe\x00\x00\x35\xff\xf0\xfe\xf1\xfe\x3c\xff\xf0\xfe\x78\xff\x74\xff\x79\xff\x7c\xff\x7a\xff\x7b\xff\x7d\xff\x73\xff\x77\xff\xa8\xff\x6c\xff\x62\xff\x63\xff\x61\xff\xf1\xfe\x5a\xff\x00\x00\x5f\xff\x5e\xff\x00\x00\x68\xff\x69\xff\x5d\xff\x00\x00\x00\x00\xf1\xfe\x42\xff\xf1\xfe\xf0\xfe\x00\x00\xf1\xfe\x89\xff\xf0\xfe\xf1\xfe\x00\x00\x24\xff\x22\xff\x10\xff\x25\xff\x13\xff\xe9\xff\x00\x00\xca\xff\xd0\xff\xd3\xff\xe2\xff\xd5\xff\x00\x00\x1a\xff\x1f\xff\xbd\xff\xe3\xff\x91\xff\x00\x00\xf0\xfe\xe5\xff\xf1\xfe\x9a\xff\x00\x00\xf1\xfe\x00\x00\x59\xff\x66\xff\x5b\xff\x37\xff\x00\x00\x00\x00\xe7\xff\xf1\xfe\xcd\xff\x92\xff\x00\x00\x90\xff\x00\x00\xe6\xff\x3a\xff\x36\xff\x8f\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x03\x00\x01\x00\x0b\x00\x25\x00\x03\x00\x08\x00\x1a\x00\x29\x00\x1a\x00\x02\x00\x03\x00\x02\x00\x0c\x00\x0c\x00\x1a\x00\x12\x00\x10\x00\x4c\x00\x0b\x00\x13\x00\x0a\x00\x21\x00\x4c\x00\x1a\x00\x11\x00\x12\x00\x13\x00\x4c\x00\x15\x00\x01\x00\x17\x00\x02\x00\x19\x00\x20\x00\x21\x00\x16\x00\x1d\x00\x2a\x00\x1d\x00\x1a\x00\x0c\x00\x22\x00\x23\x00\x4d\x00\x10\x00\x26\x00\x27\x00\x2a\x00\x27\x00\x45\x00\x46\x00\x45\x00\x46\x00\x2e\x00\x2f\x00\x2e\x00\x41\x00\x4c\x00\x1d\x00\x31\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x25\x00\x01\x00\x1a\x00\x4d\x00\x3c\x00\x1d\x00\x2e\x00\x4b\x00\x4d\x00\x4e\x00\x4d\x00\x43\x00\x0c\x00\x4d\x00\x2a\x00\x54\x00\x10\x00\x02\x00\x57\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x5a\x00\x5b\x00\x01\x00\x5d\x00\x11\x00\x02\x00\x03\x00\x1a\x00\x4d\x00\x4e\x00\x25\x00\x4d\x00\x4d\x00\x0c\x00\x0b\x00\x54\x00\x1d\x00\x10\x00\x57\x00\x74\x00\x13\x00\x4d\x00\x13\x00\x78\x00\x15\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x20\x00\x21\x00\x25\x00\x1d\x00\x2e\x00\x4c\x00\x7d\x00\x11\x00\x22\x00\x23\x00\x20\x00\x21\x00\x1a\x00\x27\x00\x02\x00\x1a\x00\x1a\x00\x25\x00\x74\x00\x43\x00\x2e\x00\x4d\x00\x78\x00\x4c\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x07\x00\x11\x00\x25\x00\x25\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x1d\x00\x4d\x00\x4b\x00\x20\x00\x02\x00\x03\x00\x1a\x00\x1b\x00\x4d\x00\x4e\x00\x27\x00\x42\x00\x4b\x00\x0b\x00\x42\x00\x54\x00\x4d\x00\x2e\x00\x57\x00\x11\x00\x12\x00\x13\x00\x25\x00\x15\x00\x07\x00\x17\x00\x05\x00\x19\x00\x4d\x00\x4d\x00\x4d\x00\x1d\x00\x34\x00\x02\x00\x03\x00\x4c\x00\x22\x00\x23\x00\x3a\x00\x4c\x00\x26\x00\x27\x00\x0b\x00\x1a\x00\x1b\x00\x25\x00\x02\x00\x74\x00\x2e\x00\x2f\x00\x13\x00\x78\x00\x15\x00\x7a\x00\x7b\x00\x7c\x00\x25\x00\x4c\x00\x7d\x00\x26\x00\x1d\x00\x11\x00\x4d\x00\x25\x00\x4c\x00\x22\x00\x23\x00\x02\x00\x03\x00\x34\x00\x27\x00\x1a\x00\x25\x00\x1d\x00\x25\x00\x3a\x00\x0b\x00\x2e\x00\x2e\x00\x25\x00\x30\x00\x24\x00\x26\x00\x25\x00\x13\x00\x4d\x00\x15\x00\x03\x00\x02\x00\x03\x00\x2e\x00\x01\x00\x5a\x00\x5b\x00\x1d\x00\x5d\x00\x4d\x00\x0b\x00\x25\x00\x22\x00\x23\x00\x4d\x00\x12\x00\x4d\x00\x27\x00\x13\x00\x10\x00\x15\x00\x25\x00\x02\x00\x03\x00\x2e\x00\x4d\x00\x11\x00\x4d\x00\x1d\x00\x0a\x00\x0b\x00\x0b\x00\x4d\x00\x22\x00\x23\x00\x1a\x00\x4d\x00\x25\x00\x27\x00\x13\x00\x7d\x00\x15\x00\x25\x00\x02\x00\x03\x00\x2e\x00\x0a\x00\x0b\x00\x25\x00\x1d\x00\x25\x00\x4d\x00\x0b\x00\x25\x00\x22\x00\x23\x00\x1a\x00\x01\x00\x25\x00\x27\x00\x13\x00\x4d\x00\x15\x00\x21\x00\x02\x00\x03\x00\x2e\x00\x0d\x00\x0e\x00\x7d\x00\x1d\x00\x25\x00\x10\x00\x0b\x00\x25\x00\x22\x00\x23\x00\x4d\x00\x1a\x00\x25\x00\x27\x00\x13\x00\x4d\x00\x15\x00\x20\x00\x02\x00\x03\x00\x2e\x00\x4d\x00\x1a\x00\x4d\x00\x1d\x00\x1a\x00\x4d\x00\x0b\x00\x25\x00\x22\x00\x23\x00\x4d\x00\x24\x00\x13\x00\x27\x00\x13\x00\x7d\x00\x15\x00\x1a\x00\x02\x00\x03\x00\x2e\x00\x1e\x00\x1f\x00\x4d\x00\x1d\x00\x20\x00\x4d\x00\x0b\x00\x1a\x00\x22\x00\x23\x00\x4d\x00\x02\x00\x1a\x00\x27\x00\x13\x00\x7d\x00\x15\x00\x24\x00\x02\x00\x03\x00\x2e\x00\x23\x00\x1a\x00\x42\x00\x1d\x00\x1a\x00\x4d\x00\x0b\x00\x1a\x00\x22\x00\x23\x00\x23\x00\x21\x00\x1a\x00\x27\x00\x13\x00\x7d\x00\x15\x00\x1d\x00\x02\x00\x03\x00\x2e\x00\x4c\x00\x22\x00\x23\x00\x1d\x00\x1a\x00\x1a\x00\x0b\x00\x1d\x00\x22\x00\x23\x00\x13\x00\x20\x00\x4c\x00\x27\x00\x13\x00\x7d\x00\x15\x00\x1a\x00\x02\x00\x03\x00\x2e\x00\x02\x00\x03\x00\x1a\x00\x1d\x00\x0a\x00\x1a\x00\x0b\x00\x0d\x00\x22\x00\x23\x00\x28\x00\x20\x00\x4d\x00\x27\x00\x13\x00\x7d\x00\x15\x00\x18\x00\x19\x00\x31\x00\x2e\x00\x33\x00\x34\x00\x0a\x00\x1d\x00\x37\x00\x0d\x00\x1d\x00\x3a\x00\x22\x00\x23\x00\x4c\x00\x22\x00\x23\x00\x27\x00\x1a\x00\x7d\x00\x27\x00\x4c\x00\x1e\x00\x1f\x00\x2e\x00\x4c\x00\x49\x00\x2e\x00\x2e\x00\x4d\x00\x30\x00\x3d\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x02\x00\x03\x00\x4d\x00\x01\x00\x7d\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0d\x00\x0e\x00\x2d\x00\x09\x00\x2d\x00\x10\x00\x31\x00\x32\x00\x31\x00\x14\x00\x4c\x00\x16\x00\x7d\x00\x18\x00\x1d\x00\x3a\x00\x1b\x00\x3a\x00\x4c\x00\x22\x00\x23\x00\x18\x00\x19\x00\x26\x00\x27\x00\x48\x00\x25\x00\x4a\x00\x48\x00\x28\x00\x4a\x00\x2e\x00\x48\x00\x7d\x00\x4a\x00\x1a\x00\x48\x00\x4c\x00\x4a\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x4c\x00\x28\x00\x4f\x00\x50\x00\x5e\x00\x5f\x00\x7d\x00\x48\x00\x49\x00\x7d\x00\x31\x00\x4d\x00\x33\x00\x34\x00\x4c\x00\x2a\x00\x37\x00\x55\x00\x56\x00\x3a\x00\x3b\x00\x1a\x00\x51\x00\x52\x00\x53\x00\x2f\x00\x4c\x00\x4c\x00\x57\x00\x58\x00\x5d\x00\x4c\x00\x47\x00\x01\x00\x02\x00\x5e\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x0e\x00\x0f\x00\x10\x00\x75\x00\x76\x00\x77\x00\x14\x00\x03\x00\x16\x00\x4c\x00\x18\x00\x4c\x00\x08\x00\x1b\x00\x4d\x00\x1d\x00\x4d\x00\x4d\x00\x4d\x00\x4c\x00\x22\x00\x23\x00\x12\x00\x25\x00\x26\x00\x4d\x00\x28\x00\x4c\x00\x4c\x00\x4c\x00\x1a\x00\x4c\x00\x2e\x00\x4c\x00\x4c\x00\x4c\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x4f\x00\x4c\x00\x51\x00\x52\x00\x53\x00\x4c\x00\x4c\x00\x4c\x00\x57\x00\x58\x00\x59\x00\x01\x00\x02\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x4d\x00\x4d\x00\x09\x00\x03\x00\x0e\x00\x0f\x00\x10\x00\x4d\x00\x08\x00\x4d\x00\x14\x00\x1a\x00\x16\x00\x4c\x00\x18\x00\x1a\x00\x4c\x00\x1b\x00\x12\x00\x1d\x00\x4c\x00\x0e\x00\x02\x00\x03\x00\x22\x00\x23\x00\x1a\x00\x25\x00\x4c\x00\x4c\x00\x28\x00\x02\x00\x03\x00\x1a\x00\x1b\x00\x4c\x00\x06\x00\x1e\x00\x1f\x00\x4c\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\x4c\x00\x4c\x00\x2d\x00\x4d\x00\x22\x00\x23\x00\x31\x00\x32\x00\x1d\x00\x27\x00\x4d\x00\x4d\x00\x4c\x00\x22\x00\x23\x00\x3a\x00\x2e\x00\x4c\x00\x27\x00\x4f\x00\x4c\x00\x51\x00\x52\x00\x53\x00\x4d\x00\x2e\x00\x2f\x00\x57\x00\x58\x00\x59\x00\x01\x00\x4d\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x4c\x00\x4c\x00\x1a\x00\x1b\x00\x0e\x00\x0f\x00\x10\x00\x4d\x00\x4c\x00\x4c\x00\x14\x00\x2a\x00\x16\x00\x2b\x00\x18\x00\x4c\x00\x2a\x00\x1b\x00\x4c\x00\x1d\x00\x4d\x00\x2d\x00\x5b\x00\x02\x00\x03\x00\x31\x00\x4c\x00\x25\x00\x4c\x00\x2a\x00\x28\x00\x02\x00\x03\x00\x05\x00\x3a\x00\x1a\x00\x4d\x00\x4d\x00\x4d\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x4d\x00\x1d\x00\x05\x00\x1a\x00\x1a\x00\x19\x00\x22\x00\x23\x00\x4d\x00\x1d\x00\x4d\x00\x27\x00\x1a\x00\x1a\x00\x22\x00\x23\x00\x02\x00\x03\x00\x2e\x00\x27\x00\x4f\x00\x0e\x00\x51\x00\x52\x00\x53\x00\x0b\x00\x2e\x00\x17\x00\x57\x00\x58\x00\x59\x00\x01\x00\x06\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x4d\x00\x4d\x00\x4d\x00\x1d\x00\x0e\x00\x0f\x00\x10\x00\x1a\x00\x22\x00\x23\x00\x14\x00\x4d\x00\x16\x00\x27\x00\x18\x00\x1a\x00\x26\x00\x1b\x00\x4d\x00\x1d\x00\x2e\x00\x4d\x00\x5a\x00\x02\x00\x03\x00\x1a\x00\x48\x00\x25\x00\x13\x00\x11\x00\x28\x00\x02\x00\x03\x00\x11\x00\x15\x00\x15\x00\x15\x00\x2e\x00\x11\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x26\x00\x1d\x00\x03\x00\x17\x00\x13\x00\x4a\x00\x22\x00\x23\x00\x10\x00\x1d\x00\x26\x00\x27\x00\x04\x00\x13\x00\x22\x00\x23\x00\x02\x00\x03\x00\x2e\x00\x27\x00\x4f\x00\x15\x00\x51\x00\x52\x00\x53\x00\x26\x00\x2e\x00\x11\x00\x57\x00\x58\x00\x59\x00\x01\x00\x12\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x11\x00\x26\x00\x14\x00\x1d\x00\x0e\x00\x0f\x00\x10\x00\x0c\x00\x22\x00\x23\x00\x14\x00\x0b\x00\x16\x00\x27\x00\x18\x00\x2e\x00\x14\x00\x1b\x00\x14\x00\x1d\x00\x2e\x00\x20\x00\x02\x00\x03\x00\x2e\x00\x11\x00\x11\x00\x25\x00\x11\x00\x11\x00\x28\x00\x02\x00\x03\x00\x1a\x00\x1b\x00\x11\x00\x14\x00\x2e\x00\x2e\x00\x13\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\x15\x00\x11\x00\x2d\x00\x11\x00\x22\x00\x23\x00\x31\x00\x0a\x00\x1d\x00\x27\x00\x15\x00\x13\x00\x31\x00\x22\x00\x23\x00\x3a\x00\x2e\x00\x26\x00\x27\x00\x4f\x00\x20\x00\x51\x00\x52\x00\x53\x00\x14\x00\x2e\x00\x0b\x00\x57\x00\x58\x00\x59\x00\x01\x00\x26\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x04\x00\x20\x00\x0b\x00\x13\x00\x0e\x00\x0f\x00\x10\x00\x20\x00\x26\x00\x11\x00\x14\x00\x11\x00\x16\x00\x0a\x00\x18\x00\x11\x00\x13\x00\x1b\x00\x13\x00\x1d\x00\x13\x00\x13\x00\x02\x00\x03\x00\x02\x00\x03\x00\x13\x00\x25\x00\x0b\x00\x15\x00\x28\x00\x26\x00\x5e\x00\x0c\x00\x0b\x00\x31\x00\x20\x00\x11\x00\x26\x00\x11\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\x13\x00\x1d\x00\x0d\x00\x15\x00\x22\x00\x23\x00\x22\x00\x23\x00\x26\x00\x27\x00\x26\x00\x27\x00\x15\x00\x0b\x00\x13\x00\x13\x00\x2e\x00\x11\x00\x2e\x00\x4f\x00\x11\x00\x51\x00\x52\x00\x53\x00\x26\x00\x11\x00\x0a\x00\x57\x00\x58\x00\x59\x00\x01\x00\x26\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x03\x00\x1a\x00\x1b\x00\x26\x00\x0e\x00\x0f\x00\x10\x00\x13\x00\x20\x00\x2f\x00\x14\x00\x0a\x00\x16\x00\x11\x00\x18\x00\x0a\x00\x26\x00\x1b\x00\x03\x00\x1d\x00\x2d\x00\x11\x00\x5d\x00\x11\x00\x31\x00\x11\x00\x0a\x00\x25\x00\x0a\x00\x12\x00\x28\x00\x02\x00\x03\x00\x3a\x00\x0b\x00\x0b\x00\x11\x00\x10\x00\x1a\x00\x1b\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x04\x00\x04\x00\x01\x00\x12\x00\x04\x00\x19\x00\x10\x00\x41\x00\x2d\x00\x1d\x00\x10\x00\x10\x00\x31\x00\x14\x00\x22\x00\x23\x00\x02\x00\x03\x00\x26\x00\x27\x00\x4f\x00\x3a\x00\x51\x00\x52\x00\x53\x00\x0b\x00\x2e\x00\x12\x00\x57\x00\x58\x00\x59\x00\x01\x00\x0c\x00\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x12\x00\x12\x00\x12\x00\x1d\x00\x0e\x00\x0f\x00\x10\x00\x12\x00\x22\x00\x23\x00\x14\x00\x05\x00\x16\x00\x27\x00\x18\x00\x7d\x00\x7d\x00\x1b\x00\x20\x00\x1d\x00\x2e\x00\xff\xff\x02\x00\x03\x00\x02\x00\x03\x00\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\x0b\x00\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\xff\xff\x1d\x00\xff\xff\xff\xff\x22\x00\x23\x00\x22\x00\x23\x00\xff\xff\x27\x00\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x2e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\x01\x00\xff\xff\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\xff\xff\xff\xff\x02\x00\x03\x00\x02\x00\x03\x00\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\xff\xff\x1d\x00\xff\xff\xff\xff\x22\x00\x23\x00\x22\x00\x23\x00\xff\xff\x27\x00\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x2e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\x01\x00\xff\xff\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\xff\xff\xff\xff\x02\x00\x03\x00\x02\x00\x03\x00\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\xff\xff\x1d\x00\xff\xff\xff\xff\x22\x00\x23\x00\x22\x00\x23\x00\xff\xff\x27\x00\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x2e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x1a\x00\x1b\x00\x57\x00\x58\x00\x59\x00\x01\x00\xff\xff\x5c\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\x2d\x00\x10\x00\xff\xff\xff\xff\x31\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x3a\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x03\x00\x25\x00\x0a\x00\x0b\x00\x28\x00\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x20\x00\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x23\x00\xff\xff\x01\x00\xff\xff\x27\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x2e\x00\x0b\x00\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\xff\xff\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\x0b\x00\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x28\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x31\x00\x1b\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\x01\x00\x31\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\x3a\x00\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\xff\xff\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x01\x00\x31\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x3a\x00\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x28\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x31\x00\x1b\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\x0b\x00\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x28\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x31\x00\x1b\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\x01\x00\x31\x00\xff\xff\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\x3a\x00\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x11\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x11\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x11\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x11\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\xff\xff\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x28\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x31\x00\x1b\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\x3b\x00\x25\x00\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\x10\x00\x28\x00\x57\x00\x58\x00\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x31\x00\x1b\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x25\x00\xff\xff\xff\xff\x01\x00\x1a\x00\x1b\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x22\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x2c\x00\x2d\x00\x16\x00\xff\xff\x18\x00\x31\x00\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x02\x00\x03\x00\x01\x00\x02\x00\xff\xff\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\x52\x00\x53\x00\xff\xff\xff\xff\x1d\x00\x57\x00\x58\x00\x1d\x00\xff\xff\x22\x00\x23\x00\xff\xff\x22\x00\x23\x00\x27\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x01\x00\xff\xff\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x10\x00\x1a\x00\xff\xff\x1c\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\x31\x00\xff\xff\x33\x00\x34\x00\x35\x00\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x01\x00\xff\xff\xff\xff\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x4d\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x00\x52\x00\x53\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\xff\xff\x01\x00\x1a\x00\x1b\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x22\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x10\x00\xff\xff\xff\xff\xff\xff\x2c\x00\x2d\x00\x52\x00\x53\x00\x18\x00\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x03\x00\x3a\x00\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\x13\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x1d\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x2e\x00\x2f\x00\xff\xff\x31\x00\xff\xff\xff\xff\x52\x00\x53\x00\x0c\x00\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\x15\x00\xff\xff\x41\x00\xff\xff\xff\xff\x1a\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x4a\x00\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x0c\x00\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\x0c\x00\x14\x00\x15\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x1a\x00\x14\x00\x15\x00\x00\x00\x01\x00\x02\x00\x03\x00\x1a\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x0c\x00\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\x15\x00\x00\x00\x01\x00\x02\x00\x03\x00\x1a\x00\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x0c\x00\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\x0c\x00\x14\x00\x15\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x1a\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x31\x00\xff\xff\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\x1a\x00\x3a\x00\x1c\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x4d\x00\xff\xff\xff\xff\x31\x00\xff\xff\x33\x00\x34\x00\xff\xff\x31\x00\x37\x00\x33\x00\x34\x00\x3a\x00\xff\xff\x37\x00\xff\xff\x1a\x00\x3a\x00\x1c\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x4d\x00\xff\xff\x26\x00\x27\x00\x28\x00\x4d\x00\xff\xff\xff\xff\x31\x00\xff\xff\x33\x00\x34\x00\xff\xff\x31\x00\x37\x00\x33\x00\x34\x00\x3a\x00\x0e\x00\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\xff\xff\xff\xff\x0e\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x4d\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x31\x00\xff\xff\x33\x00\x34\x00\x35\x00\xff\xff\x37\x00\xff\xff\x31\x00\x3a\x00\x33\x00\x34\x00\x35\x00\x1a\x00\x37\x00\x1c\x00\xff\xff\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x22\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x36\x00\x37\x00\x3a\x00\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\x35\x00\x22\x00\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x36\x00\x37\x00\x3a\x00\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x22\x00\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\x3a\x00\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x22\x00\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\x3a\x00\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x22\x00\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\x3a\x00\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\x22\x00\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\x3a\x00\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x31\x00\x1c\x00\x33\x00\x34\x00\x1a\x00\xff\xff\x37\x00\xff\xff\x28\x00\x3a\x00\xff\xff\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\xff\xff\x31\x00\x28\x00\x33\x00\x34\x00\x1a\x00\x31\x00\x37\x00\x33\x00\x34\x00\x3a\x00\x31\x00\x37\x00\x33\x00\x34\x00\x3a\x00\xff\xff\x37\x00\x1a\x00\x28\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x31\x00\xff\xff\x33\x00\x34\x00\x28\x00\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x1a\x00\x28\x00\x31\x00\xff\xff\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\x31\x00\x3a\x00\x33\x00\x34\x00\x28\x00\xff\xff\x37\x00\x1a\x00\xff\xff\x3a\x00\xff\xff\xff\xff\xff\xff\x31\x00\xff\xff\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\x28\x00\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\xff\xff\x33\x00\x34\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x19\x02\x25\x00\x30\x02\xbf\x00\xc3\x00\x6c\x02\xfd\x01\x04\x01\xfd\x01\xc2\x00\xc3\x00\xf6\x00\x57\x00\xd9\xff\x72\x02\x4d\x00\x58\x00\x88\x02\x9d\xff\xfc\xff\xec\x00\x8b\x02\x7f\x02\x50\x00\x9d\xff\x9d\xff\x9d\xff\x81\x02\x9d\xff\x25\x00\x9d\xff\xf6\x00\x9d\xff\xd9\xff\xd9\xff\x71\x01\xc4\x00\x89\x01\xf7\x00\x72\x01\x57\x00\xc5\x00\xc6\x00\xc0\x00\x58\x00\x9d\xff\xc7\x00\x0c\x01\xb0\x01\x65\x02\xff\x01\xfe\x01\xff\x01\xc8\x00\x9d\xff\xf8\x00\x5e\x00\x75\x02\xf7\x00\x70\xff\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xbf\x00\x25\x00\xbb\x00\xc8\x00\x73\x01\xcc\x01\xf8\x00\xd9\xff\x62\x00\x63\x00\x82\x02\x74\x01\x57\x00\x3f\x01\x0c\x01\x64\x00\x58\x00\xf6\x00\x65\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x9d\xff\x9d\xff\x25\x00\x9d\xff\x3e\x02\xc2\x00\xc3\x00\x72\x01\x62\x00\x63\x00\xbf\x00\x76\x02\x79\x02\x57\x00\x06\xff\x64\x00\xf7\x00\x58\x00\x65\x00\x66\x00\xfc\xff\xc8\x00\x06\xff\x67\x00\x06\xff\x68\x00\x69\x00\x6a\x00\xfc\xff\x28\x01\x29\x01\xbf\x00\xc4\x00\xf8\x00\x77\x02\x9d\xff\x70\x02\xc5\x00\xc6\x00\x42\x01\x43\x01\x44\x01\xc7\x00\xf6\x00\x44\x01\x4e\x01\xbf\x00\x66\x00\x00\x02\xc8\x00\x59\x02\x67\x00\x7a\x02\x68\x00\x69\x00\x6a\x00\xfc\xff\x25\x01\xae\x01\xbf\x00\xbf\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xf7\x00\x5c\x02\x2a\x01\xaf\x01\xc2\x00\xc3\x00\x7d\x00\x7e\x00\x62\x00\x63\x00\xb0\x01\x6e\x02\x2a\x01\x9c\xff\x45\x01\x64\x00\xc0\x00\xf8\x00\x65\x00\x9c\xff\x9c\xff\x9c\xff\xbf\x00\x9c\xff\x7c\x00\x9c\xff\x85\x02\x9c\xff\x57\x02\x37\x02\xc0\x00\xc4\x00\x7f\x00\xc2\x00\xc3\x00\x7b\x02\xc5\x00\xc6\x00\x80\x00\x56\x02\x9c\xff\xc7\x00\x08\xff\x7d\x00\x7e\x00\xbf\x00\xf6\x00\x66\x00\xc8\x00\x9c\xff\x08\xff\x67\x00\x08\xff\x68\x00\x69\x00\x6a\x00\xbf\x00\x58\x02\x06\xff\x86\x02\xc4\x00\x6b\xff\x88\x01\xbf\x00\x5b\x02\xc5\x00\xc6\x00\xc2\x00\xc3\x00\x7f\x00\xc7\x00\x97\x00\xbf\x00\xf7\x00\xbf\x00\x80\x00\x0c\xff\xc8\x00\x4d\x02\xbf\x00\x7d\x02\x5d\x02\x6b\xff\xbf\x00\x0c\xff\x9c\x01\x0c\xff\x9c\x00\xc2\x00\xc3\x00\xf8\x00\x25\x00\x9c\xff\x9c\xff\xc4\x00\x9c\xff\x9e\x01\x0b\xff\xbf\x00\xc5\x00\xc6\x00\x5f\x02\x9d\x00\xa0\x01\xc7\x00\x0b\xff\x58\x00\x0b\xff\xbf\x00\xc2\x00\xc3\x00\xc8\x00\xa2\x01\x4d\x01\xc0\x00\xc4\x00\x69\x02\x1f\x02\x09\xff\xbb\x01\xc5\x00\xc6\x00\x4e\x01\xbe\x01\xbf\x00\xc7\x00\x09\xff\x9c\xff\x09\xff\xbf\x00\xc2\x00\xc3\x00\xc8\x00\x1e\x02\x1f\x02\xbf\x00\xc4\x00\xfb\x00\xbf\x01\x07\xff\xbf\x00\xc5\x00\xc6\x00\x72\x02\x25\x00\xbf\x00\xc7\x00\x07\xff\xc0\x01\x07\xff\x86\x02\xc2\x00\xc3\x00\xc8\x00\xf4\x01\x24\x01\x08\xff\xc4\x00\xbf\x00\x58\x00\x02\xff\xbf\x00\xc5\x00\xc6\x00\xc1\x01\xd6\x00\xfb\x00\xc7\x00\x02\xff\xc2\x01\x02\xff\xaa\x01\xc2\x00\xc3\x00\xc8\x00\xc0\x00\x85\x01\xfc\x00\xc4\x00\x44\x01\xc0\x00\x01\xff\xbf\x00\xc5\x00\xc6\x00\x14\x01\x98\x00\x32\x01\xc7\x00\x01\xff\x0c\xff\x01\xff\xec\x00\xc2\x00\xc3\x00\xc8\x00\xcf\x01\xee\x00\x16\x01\xc4\x00\x33\x01\xc0\x00\xfe\xfe\x97\x00\xc5\x00\xc6\x00\xfc\x00\x79\x00\x48\x01\xc7\x00\xfe\xfe\x0b\xff\xfe\xfe\x98\x00\xc2\x00\xc3\x00\xc8\x00\x59\x01\x48\x01\x47\x01\xc4\x00\x72\x02\xc0\x00\xfd\xfe\x60\x02\xc5\x00\xc6\x00\x49\x01\x73\x02\x6d\x02\xc7\x00\xfd\xfe\x09\xff\xfd\xfe\x7a\x00\xc2\x00\xc3\x00\xc8\x00\x62\x02\x7b\x00\x7c\x00\xc4\x00\xbb\x00\xd6\x00\xfc\xfe\xbc\x00\xc5\x00\xc6\x00\x8a\x00\xc3\x01\x66\x02\xc7\x00\xfc\xfe\x07\xff\xfc\xfe\x1a\x00\xc2\x00\xc3\x00\xc8\x00\xc2\x00\xc3\x00\x14\x02\xc4\x00\xb2\x01\xd6\x00\xfb\xfe\x70\xff\xc5\x00\xc6\x00\x1e\x00\xd7\x00\x25\x02\xc7\x00\xfb\xfe\x02\xff\xfb\xfe\xf8\x01\x2b\x01\x1f\x00\xc8\x00\x8b\x00\x21\x00\xec\x00\xc4\x00\x22\x00\x70\xff\xc4\x00\x23\x00\xc5\x00\xc6\x00\x1b\x02\xc5\x00\xc6\x00\xc7\x00\xec\x00\x01\xff\xc7\x00\x1d\x02\xed\x00\xee\x00\xc8\x00\x26\x02\x8c\x00\xc8\x00\x4d\x02\x2d\x02\x4e\x02\x2e\x02\x7d\x00\xb2\x00\x7d\x00\xb2\x00\xc2\x00\xc3\x00\x3b\x02\x25\x00\xfe\xfe\x8e\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x8f\x00\x23\x01\x24\x01\xd3\x01\x33\x02\x53\x02\x2e\x00\xb6\x00\xd4\x01\xb6\x00\x2f\x00\x30\x02\x30\x00\xfd\xfe\x31\x00\xc4\x00\x80\x00\x32\x00\x80\x00\x31\x02\xc5\x00\xc6\x00\x2a\x01\x2b\x01\x36\x02\xc7\x00\x0d\x01\x34\x00\xe9\x01\x0d\x01\x35\x00\x70\x01\xc8\x00\x0d\x01\xfc\xfe\x0e\x01\x1a\x00\x0d\x01\x47\x02\x0f\x01\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x49\x02\x1e\x00\x50\x02\x51\x02\xa7\x00\xa8\x00\xfb\xfe\x2d\x01\x2e\x01\xff\xff\x1f\x00\x4c\x02\x29\x02\x21\x00\x4a\x02\xf0\x01\x22\x00\x21\x02\x22\x02\x23\x00\x2a\x02\x06\x00\x40\x00\x41\x00\x42\x00\xd1\x01\x4b\x02\xc4\x01\x43\x00\x44\x00\x8a\xff\xc5\x01\x2b\x02\x25\x00\xad\x00\x90\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xc6\x01\xc7\x01\xc8\x01\xc9\x01\x2c\x00\x2d\x00\x2e\x00\x23\x02\x24\x02\x25\x02\x2f\x00\x19\x02\x30\x00\xca\x01\x31\x00\xcb\x01\x1a\x02\x32\x00\xd6\x01\xae\x00\xd7\x01\xd8\x01\xda\x01\xdc\x01\xaf\x00\xb0\x00\x4d\x00\x34\x00\xb1\x00\xf9\x01\x35\x00\xde\x01\xe0\x01\xe1\x01\x50\x00\xe2\x01\xb2\x00\xe3\x01\xe4\x01\xe5\x01\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x3f\x00\xe6\x01\x40\x00\x41\x00\x42\x00\xe7\x01\xec\x01\xef\x01\x43\x00\x44\x00\x45\x00\x25\x00\x79\x00\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xfa\x01\x01\x02\x03\x02\x19\x02\x2c\x00\x2d\x00\x2e\x00\x05\x02\x34\x02\x07\x02\x2f\x00\x0c\x02\x30\x00\x52\x01\x31\x00\x55\x01\x57\x01\x32\x00\x4d\x00\xae\x00\x61\x01\x77\x00\xc2\x00\xc3\x00\x7b\x00\x7c\x00\x50\x00\x34\x00\x62\x01\x66\x01\x35\x00\xc2\x00\xc3\x00\xef\x00\xb2\x00\x67\x01\x7e\x01\xf0\x00\xee\x00\x8a\x01\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xc4\x00\x8b\x01\x8c\x01\xf1\x00\x8e\x01\xc5\x00\xc6\x00\xb6\x00\xf2\x00\xc4\x00\xc7\x00\x9b\x01\x9d\x01\x9f\x01\xc5\x00\xc6\x00\x80\x00\xc8\x00\xa1\x01\xc7\x00\x3f\x00\xa3\x01\x40\x00\x41\x00\x42\x00\xb8\x01\xc8\x00\x51\x01\x43\x00\x44\x00\x45\x00\x25\x00\xb9\x01\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xbd\x01\xdc\x00\x7d\x00\xb2\x00\x2c\x00\x2d\x00\x2e\x00\xe2\x00\xe5\x00\xe8\x00\x2f\x00\xea\x00\x30\x00\xf9\x00\x31\x00\x10\x01\x1e\x01\x32\x00\x17\x01\x33\x00\x15\x01\x52\x02\xf3\x01\xc2\x00\xc3\x00\xb6\x00\x18\x01\x34\x00\x1f\x01\x22\x01\x35\x00\xc2\x00\xc3\x00\x26\x01\x80\x00\x2e\x01\x3a\x01\x3b\x01\x3e\x01\xd2\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x01\xc4\x00\x40\x01\x46\x01\x71\x00\xee\x01\xc5\x00\xc6\x00\x4a\x01\xc4\x00\x4f\x01\xc7\x00\x72\x00\x73\x00\xc5\x00\xc6\x00\xc2\x00\xc3\x00\xc8\x00\xc7\x00\x3f\x00\x77\x00\x40\x00\x41\x00\x42\x00\x16\x02\xc8\x00\x90\x00\x43\x00\x44\x00\x45\x00\x25\x00\x92\x00\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x9a\x00\x9d\x00\x9e\x00\xc4\x00\x2c\x00\x2d\x00\x2e\x00\xa0\x00\xc5\x00\xc6\x00\x2f\x00\xa5\x00\x30\x00\xc7\x00\x31\x00\xcf\x00\x88\x02\x32\x00\xbd\x00\x33\x00\xc8\x00\xc8\x00\x21\x01\xc2\x00\xc3\x00\xd5\x00\x04\x00\x34\x00\x8a\x02\x84\x02\x35\x00\xc2\x00\xc3\x00\x7d\x02\x72\x02\x75\x02\x55\x02\xf8\x00\x40\xff\xd4\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x56\x02\xc4\x00\x00\x00\x12\x01\x5f\x02\x62\x02\xc5\x00\xc6\x00\x68\x02\xc4\x00\x66\x01\xc7\x00\x69\x02\x6c\x02\xc5\x00\xc6\x00\xc2\x00\xc3\x00\xc8\x00\xc7\x00\x3f\x00\x6b\x02\x40\x00\x41\x00\x42\x00\x14\x02\xc8\x00\x70\x02\x43\x00\x44\x00\x45\x00\x25\x00\xf6\x01\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x17\x02\x18\x02\x19\x02\xc4\x00\x2c\x00\x2d\x00\x2e\x00\x28\x02\xc5\x00\xc6\x00\x2f\x00\x29\x02\x30\x00\xc7\x00\x31\x00\x52\x02\x33\x02\x32\x00\x05\x02\x33\x00\xc8\x00\x39\x02\xc2\x00\xc3\x00\xcf\x01\x3f\x02\x40\x02\x34\x00\x41\x02\x42\x02\x35\x00\xc2\x00\xc3\x00\x7d\x00\xb2\x00\x43\x02\xd3\x01\xf8\x00\xda\x01\x87\xff\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xc4\x00\x3d\xff\xde\x01\xd5\x01\xe0\x01\xc5\x00\xc6\x00\xb6\x00\xec\x00\xc4\x00\xc7\x00\xeb\x01\x03\x02\xef\x01\xc5\x00\xc6\x00\x80\x00\xc8\x00\xec\x01\xc7\x00\x3f\x00\xfd\x01\x40\x00\x41\x00\x42\x00\x05\x02\xc8\x00\x0f\x02\x43\x00\x44\x00\x45\x00\x25\x00\x10\x02\x1e\x01\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x11\x02\x54\x01\x12\x02\x55\x01\x2c\x00\x2d\x00\x2e\x00\x59\x01\x5c\x01\x5b\x01\x2f\x00\x5d\x01\x30\x00\x5e\x01\x31\x00\x64\x01\x69\x01\x32\x00\x6a\x01\x33\x00\x6b\x01\x6c\x01\xc2\x00\xc3\x00\x06\x01\xc3\x00\x6d\x01\x34\x00\x70\x01\x7a\x01\x35\x00\x79\x01\x7b\x01\x94\x00\x81\x01\x85\x01\x82\x01\x65\x01\x80\x01\x07\x01\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xc4\x00\x88\x01\x08\x01\x95\x01\x92\x01\xc5\x00\xc6\x00\x09\x01\x0a\x01\x66\x01\xc7\x00\x0b\x01\xc7\x00\x93\x01\x94\x01\xa5\x01\xa7\x01\xc8\x00\xad\x01\x0c\x01\x3f\x00\xb1\x01\x40\x00\x41\x00\x42\x00\xb3\x01\xb4\x01\xb5\x01\x43\x00\x44\x00\x45\x00\x25\x00\xb7\x01\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x7d\x00\xb2\x00\xda\x00\x2c\x00\x2d\x00\x2e\x00\xe7\x00\xe4\x00\xea\x00\x2f\x00\xec\x00\x30\x00\xf9\x00\x31\x00\xfb\x00\xf5\x00\x32\x00\x00\x00\x33\x00\xe8\x01\xc3\xff\x22\x01\xc4\xff\xb6\x00\x03\x01\xec\x00\x34\x00\xec\x00\x30\x01\x35\x00\xc2\x00\xc3\x00\x80\x00\x34\x01\x4c\x01\x44\x01\x4d\x01\x7d\x00\xb2\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x6b\x00\x6c\x00\x6e\x00\x6f\x00\x71\x00\x13\x01\x75\x00\x70\x00\xa5\x01\xc4\x00\x76\x00\x77\x00\xb6\x00\x92\x00\xc5\x00\xc6\x00\xc2\x00\xc3\x00\x14\x01\xc7\x00\x3f\x00\x80\x00\x40\x00\x41\x00\x42\x00\xf7\x01\xc8\x00\x86\x00\x43\x00\x44\x00\x45\x00\x25\x00\x94\x00\x1e\x01\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x87\x00\x88\x00\x89\x00\xc4\x00\x2c\x00\x2d\x00\x2e\x00\x8a\x00\xc5\x00\xc6\x00\x2f\x00\x95\x00\x30\x00\xc7\x00\x31\x00\xff\xff\xff\xff\x32\x00\xbf\x00\x33\x00\xc8\x00\x00\x00\xc2\x00\xc3\x00\xc2\x00\xc3\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\xf8\x01\x00\x00\x0a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xc4\x00\x00\x00\xc4\x00\x00\x00\x00\x00\xc5\x00\xc6\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\xc8\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x25\x00\x00\x00\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x33\x00\x00\x00\x00\x00\xc2\x00\xc3\x00\xc2\x00\xc3\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x0b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x02\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xc4\x00\x00\x00\xc4\x00\x00\x00\x00\x00\xc5\x00\xc6\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\xc8\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x25\x00\x00\x00\x1e\x01\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x33\x00\x00\x00\x00\x00\xc2\x00\xc3\x00\xc2\x00\xc3\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x13\x02\x00\x00\x00\x00\x00\x00\x00\x00\x09\x02\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xc4\x00\x00\x00\xc4\x00\x00\x00\x00\x00\xc5\x00\xc6\x00\xc5\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\xc8\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x7d\x00\xb2\x00\x43\x00\x44\x00\x45\x00\x25\x00\x00\x00\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x8b\x02\x00\x00\x00\x00\x00\x00\xa7\x01\x2e\x00\x00\x00\x00\x00\xb6\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x80\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\xc3\x00\x34\x00\x76\x01\x77\x01\x35\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x78\x01\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\xc6\x00\x00\x00\x25\x00\x00\x00\xc7\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xc8\x00\x7f\x02\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x00\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x1a\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x79\x02\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x1e\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x1f\x00\x32\x00\x8b\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x01\x00\x00\x00\x00\x25\x00\xb6\x00\x8e\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x80\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x00\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x01\x00\x00\xa9\x01\x00\x00\x00\x00\x25\x00\xb6\x00\x1a\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2d\x02\x80\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x1e\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x1f\x00\x32\x00\x8b\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x01\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x1a\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x3a\x02\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x1e\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x1f\x00\x32\x00\x8b\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x01\x00\x00\x00\x00\x25\x00\xb6\x00\x00\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x80\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x44\x02\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x45\x02\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x46\x02\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x47\x02\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x8e\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x00\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x1a\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x1e\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x1f\x00\x32\x00\x29\x02\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x64\x02\x34\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x1a\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x2e\x00\x1e\x00\x43\x00\x44\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x1f\x00\x32\x00\xba\x01\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x63\x02\xb5\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\xc3\x00\x25\x00\x79\x00\x00\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x01\xb9\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x7a\x00\x00\x00\xc5\x00\xc6\x00\x00\x00\x7b\x00\x7c\x00\xc7\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xbb\x00\x25\x00\x00\x00\xb8\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xba\x00\x1a\x00\x00\x00\x96\x01\x00\x00\x00\x00\x00\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x21\x00\x97\x01\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xbb\x00\x25\x00\x00\x00\x00\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x98\x01\x56\x01\x47\x00\x48\x00\x49\x00\x00\x00\xb9\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x84\x00\x85\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x00\x00\x4e\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\xbb\x00\x00\x00\x25\x00\x7d\x00\xb2\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\xb3\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x82\x00\x00\x00\x00\x00\x00\x00\x48\x02\xb5\x00\x84\x00\x85\x00\x31\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\xff\xc3\x00\x80\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x65\xff\x65\xff\x65\xff\x00\x00\x00\x00\x00\x00\x65\xff\x00\x00\x65\xff\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x65\xff\x00\x00\x00\x00\x65\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\xff\x65\xff\x00\x00\x00\x00\x35\x01\x47\x00\x48\x00\x49\x00\x65\xff\x65\xff\x00\x00\x65\xff\x00\x00\x00\x00\x84\x00\x85\x00\x4a\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x00\x00\x4e\x00\x4f\x00\x00\x00\x65\xff\x00\x00\x00\x00\x50\x00\x36\x01\x47\x00\x48\x00\x49\x00\x00\x00\x65\xff\x00\x00\x37\x01\x47\x00\x48\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x4a\x00\x4e\x00\x4f\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x50\x00\x4e\x00\x4f\x00\x38\x01\x47\x00\x48\x00\x49\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x00\x00\x4e\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x01\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x4a\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x00\x00\x4e\x00\x4f\x00\x95\x00\x47\x00\x48\x00\x49\x00\x50\x00\x00\x00\x00\x00\x96\x00\x47\x00\x48\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x4a\x00\x4e\x00\x4f\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x50\x00\x4e\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x46\x00\x47\x00\x48\x00\x49\x00\x00\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x00\x00\x4d\x00\x00\x00\x4e\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x1f\x00\x00\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x1a\x00\x23\x00\xe1\x00\x00\x00\x00\x00\x1a\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x95\x01\x00\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x21\x00\x00\x00\x1f\x00\x22\x00\x20\x00\x21\x00\x23\x00\x00\x00\x22\x00\x00\x00\x1a\x00\x23\x00\xfd\x00\x00\x00\x00\x00\x1a\x00\x00\x00\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x99\x01\x00\x00\x1c\x00\x1d\x00\x1e\x00\x9a\x01\x00\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x21\x00\x00\x00\x1f\x00\x22\x00\x20\x00\x21\x00\x23\x00\x77\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\xfe\x00\x00\x00\x1a\x00\x00\x00\x3c\x01\x00\x01\x1c\x00\x1d\x00\x1e\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x20\x00\x21\x00\xab\x00\x00\x00\x22\x00\x00\x00\x1f\x00\x23\x00\x20\x00\x21\x00\x3d\x01\x19\x01\x22\x00\x1a\x01\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x01\x1f\x00\x1a\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x80\x02\x1c\x01\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x01\x1f\x00\x1a\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x86\x01\x1c\x01\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x1a\x00\x1f\x00\x8f\x01\x20\x00\x21\x00\x00\x00\xb3\x00\x22\x00\x1b\x01\x1c\x01\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\xcd\x01\xb5\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x1a\x00\x1f\x00\x96\x01\x20\x00\x21\x00\x00\x00\x3c\x02\x22\x00\x80\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x1a\x00\x1f\x00\x8f\x01\x20\x00\x21\x00\x97\x01\xb3\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\xcd\x01\xd0\x01\x00\x00\x00\x00\x00\x00\xb6\x00\x1a\x00\x1f\x00\x5a\x02\x20\x00\x21\x00\x00\x00\x90\x01\x22\x00\x80\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x1a\x00\x1f\x00\x36\x02\x20\x00\x21\x00\x00\x00\xb3\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\xfb\x01\xb5\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x1a\x00\x1f\x00\x3a\x02\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x80\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x1a\x00\x1f\x00\xf1\x01\x20\x00\x21\x00\x00\x00\xb3\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x0b\x02\xb5\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x1a\x00\x1f\x00\xf3\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x80\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x1a\x00\x1f\x00\x0d\x02\x20\x00\x21\x00\x00\x00\xb3\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x30\x01\xb5\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x1a\x00\x1f\x00\x51\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x80\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\xb2\x00\x1a\x00\x1f\x00\x5e\x01\x20\x00\x21\x00\x00\x00\xb3\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\xb4\x00\xb5\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x1a\x00\x1f\x00\x5f\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x80\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x60\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x6d\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x7b\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x7c\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x7d\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x82\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x83\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x8d\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xdf\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xe0\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xb7\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xbc\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xda\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xdb\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xdd\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xde\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xdf\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xe0\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xe1\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xe4\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xf3\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xa1\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x01\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x03\x01\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x6c\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x99\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x9f\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xa1\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xa3\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xa4\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xc9\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xca\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xcb\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xcc\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xcd\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xce\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xd0\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xd2\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xd4\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\xd8\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1f\x00\x1b\x00\x20\x00\x21\x00\x1a\x00\x00\x00\x22\x00\x00\x00\x1e\x00\x23\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1e\x00\xba\x01\x21\x00\x1a\x00\x1f\x00\x22\x00\x20\x00\x21\x00\x23\x00\x1f\x00\x22\x00\xba\x01\x21\x00\x23\x00\x00\x00\x22\x00\x1a\x00\x1e\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x1f\x00\x00\x00\xdb\x01\x21\x00\x1e\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x1a\x00\x1e\x00\x1f\x00\x00\x00\xba\x01\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x1f\x00\x23\x00\xba\x01\x21\x00\x1e\x00\x00\x00\x22\x00\x1a\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\xe7\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x1e\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\xa2\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (3, 272) [ - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50), - (51 , happyReduce_51), - (52 , happyReduce_52), - (53 , happyReduce_53), - (54 , happyReduce_54), - (55 , happyReduce_55), - (56 , happyReduce_56), - (57 , happyReduce_57), - (58 , happyReduce_58), - (59 , happyReduce_59), - (60 , happyReduce_60), - (61 , happyReduce_61), - (62 , happyReduce_62), - (63 , happyReduce_63), - (64 , happyReduce_64), - (65 , happyReduce_65), - (66 , happyReduce_66), - (67 , happyReduce_67), - (68 , happyReduce_68), - (69 , happyReduce_69), - (70 , happyReduce_70), - (71 , happyReduce_71), - (72 , happyReduce_72), - (73 , happyReduce_73), - (74 , happyReduce_74), - (75 , happyReduce_75), - (76 , happyReduce_76), - (77 , happyReduce_77), - (78 , happyReduce_78), - (79 , happyReduce_79), - (80 , happyReduce_80), - (81 , happyReduce_81), - (82 , happyReduce_82), - (83 , happyReduce_83), - (84 , happyReduce_84), - (85 , happyReduce_85), - (86 , happyReduce_86), - (87 , happyReduce_87), - (88 , happyReduce_88), - (89 , happyReduce_89), - (90 , happyReduce_90), - (91 , happyReduce_91), - (92 , happyReduce_92), - (93 , happyReduce_93), - (94 , happyReduce_94), - (95 , happyReduce_95), - (96 , happyReduce_96), - (97 , happyReduce_97), - (98 , happyReduce_98), - (99 , happyReduce_99), - (100 , happyReduce_100), - (101 , happyReduce_101), - (102 , happyReduce_102), - (103 , happyReduce_103), - (104 , happyReduce_104), - (105 , happyReduce_105), - (106 , happyReduce_106), - (107 , happyReduce_107), - (108 , happyReduce_108), - (109 , happyReduce_109), - (110 , happyReduce_110), - (111 , happyReduce_111), - (112 , happyReduce_112), - (113 , happyReduce_113), - (114 , happyReduce_114), - (115 , happyReduce_115), - (116 , happyReduce_116), - (117 , happyReduce_117), - (118 , happyReduce_118), - (119 , happyReduce_119), - (120 , happyReduce_120), - (121 , happyReduce_121), - (122 , happyReduce_122), - (123 , happyReduce_123), - (124 , happyReduce_124), - (125 , happyReduce_125), - (126 , happyReduce_126), - (127 , happyReduce_127), - (128 , happyReduce_128), - (129 , happyReduce_129), - (130 , happyReduce_130), - (131 , happyReduce_131), - (132 , happyReduce_132), - (133 , happyReduce_133), - (134 , happyReduce_134), - (135 , happyReduce_135), - (136 , happyReduce_136), - (137 , happyReduce_137), - (138 , happyReduce_138), - (139 , happyReduce_139), - (140 , happyReduce_140), - (141 , happyReduce_141), - (142 , happyReduce_142), - (143 , happyReduce_143), - (144 , happyReduce_144), - (145 , happyReduce_145), - (146 , happyReduce_146), - (147 , happyReduce_147), - (148 , happyReduce_148), - (149 , happyReduce_149), - (150 , happyReduce_150), - (151 , happyReduce_151), - (152 , happyReduce_152), - (153 , happyReduce_153), - (154 , happyReduce_154), - (155 , happyReduce_155), - (156 , happyReduce_156), - (157 , happyReduce_157), - (158 , happyReduce_158), - (159 , happyReduce_159), - (160 , happyReduce_160), - (161 , happyReduce_161), - (162 , happyReduce_162), - (163 , happyReduce_163), - (164 , happyReduce_164), - (165 , happyReduce_165), - (166 , happyReduce_166), - (167 , happyReduce_167), - (168 , happyReduce_168), - (169 , happyReduce_169), - (170 , happyReduce_170), - (171 , happyReduce_171), - (172 , happyReduce_172), - (173 , happyReduce_173), - (174 , happyReduce_174), - (175 , happyReduce_175), - (176 , happyReduce_176), - (177 , happyReduce_177), - (178 , happyReduce_178), - (179 , happyReduce_179), - (180 , happyReduce_180), - (181 , happyReduce_181), - (182 , happyReduce_182), - (183 , happyReduce_183), - (184 , happyReduce_184), - (185 , happyReduce_185), - (186 , happyReduce_186), - (187 , happyReduce_187), - (188 , happyReduce_188), - (189 , happyReduce_189), - (190 , happyReduce_190), - (191 , happyReduce_191), - (192 , happyReduce_192), - (193 , happyReduce_193), - (194 , happyReduce_194), - (195 , happyReduce_195), - (196 , happyReduce_196), - (197 , happyReduce_197), - (198 , happyReduce_198), - (199 , happyReduce_199), - (200 , happyReduce_200), - (201 , happyReduce_201), - (202 , happyReduce_202), - (203 , happyReduce_203), - (204 , happyReduce_204), - (205 , happyReduce_205), - (206 , happyReduce_206), - (207 , happyReduce_207), - (208 , happyReduce_208), - (209 , happyReduce_209), - (210 , happyReduce_210), - (211 , happyReduce_211), - (212 , happyReduce_212), - (213 , happyReduce_213), - (214 , happyReduce_214), - (215 , happyReduce_215), - (216 , happyReduce_216), - (217 , happyReduce_217), - (218 , happyReduce_218), - (219 , happyReduce_219), - (220 , happyReduce_220), - (221 , happyReduce_221), - (222 , happyReduce_222), - (223 , happyReduce_223), - (224 , happyReduce_224), - (225 , happyReduce_225), - (226 , happyReduce_226), - (227 , happyReduce_227), - (228 , happyReduce_228), - (229 , happyReduce_229), - (230 , happyReduce_230), - (231 , happyReduce_231), - (232 , happyReduce_232), - (233 , happyReduce_233), - (234 , happyReduce_234), - (235 , happyReduce_235), - (236 , happyReduce_236), - (237 , happyReduce_237), - (238 , happyReduce_238), - (239 , happyReduce_239), - (240 , happyReduce_240), - (241 , happyReduce_241), - (242 , happyReduce_242), - (243 , happyReduce_243), - (244 , happyReduce_244), - (245 , happyReduce_245), - (246 , happyReduce_246), - (247 , happyReduce_247), - (248 , happyReduce_248), - (249 , happyReduce_249), - (250 , happyReduce_250), - (251 , happyReduce_251), - (252 , happyReduce_252), - (253 , happyReduce_253), - (254 , happyReduce_254), - (255 , happyReduce_255), - (256 , happyReduce_256), - (257 , happyReduce_257), - (258 , happyReduce_258), - (259 , happyReduce_259), - (260 , happyReduce_260), - (261 , happyReduce_261), - (262 , happyReduce_262), - (263 , happyReduce_263), - (264 , happyReduce_264), - (265 , happyReduce_265), - (266 , happyReduce_266), - (267 , happyReduce_267), - (268 , happyReduce_268), - (269 , happyReduce_269), - (270 , happyReduce_270), - (271 , happyReduce_271), - (272 , happyReduce_272) - ] - -happy_n_terms = 126 :: Int -happy_n_nonterms = 79 :: Int - -happyReduce_3 = happySpecReduce_0 0# happyReduction_3 -happyReduction_3 = happyIn6 - ([] - ) - -happyReduce_4 = happySpecReduce_2 0# happyReduction_4 -happyReduction_4 happy_x_2 - happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn6 - (happy_var_1:happy_var_2 - )}} - -happyReduce_5 = happySpecReduce_2 0# happyReduction_5 -happyReduction_5 happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn6 - (map RealDecl happy_var_1 ++ happy_var_2 - )}} - -happyReduce_6 = happyReduce 4# 0# happyReduction_6 -happyReduction_6 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> - case happyOut6 happy_x_4 of { happy_var_4 -> - happyIn6 - (RealDecl (PInclude happy_var_2) : happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_7 = happySpecReduce_1 1# happyReduction_7 -happyReduction_7 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn7 - (happy_var_1 - )} - -happyReduce_8 = happySpecReduce_1 1# happyReduction_8 -happyReduction_8 happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - happyIn7 - (RealDecl (DataDecl happy_var_1) - )} - -happyReduce_9 = happySpecReduce_1 1# happyReduction_9 -happyReduction_9 happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - happyIn7 - (RealDecl happy_var_1 - )} - -happyReduce_10 = happyReduce 5# 1# happyReduction_10 -happyReduction_10 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokenName happy_var_2) -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn7 - (RealDecl (Freeze happy_var_3 happy_var_4 [] happy_var_2) - ) `HappyStk` happyRest}}} - -happyReduce_11 = happyReduce 4# 1# happyReduction_11 -happyReduction_11 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut67 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn7 - (PUsing happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_12 = happyReduce 4# 1# happyReduction_12 -happyReduction_12 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut68 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn7 - (PDoUsing happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_13 = happyReduce 4# 1# happyReduction_13 -happyReduction_13 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut69 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn7 - (PIdiom happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_14 = happyReduce 4# 1# happyReduction_14 -happyReduction_14 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut70 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn7 - (PParams happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_15 = happyReduce 4# 1# happyReduction_15 -happyReduction_15 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut71 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn7 - (PNamespace happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_16 = happySpecReduce_1 1# happyReduction_16 -happyReduction_16 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn7 - (RealDecl happy_var_1 - )} - -happyReduce_17 = happyReduce 6# 1# happyReduction_17 -happyReduction_17 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut41 happy_x_3 of { happy_var_3 -> - case happyOut34 happy_x_5 of { happy_var_5 -> - happyIn7 - (RealDecl (SynDef happy_var_2 happy_var_3 happy_var_5) - ) `HappyStk` happyRest}}} - -happyReduce_18 = happyReduce 5# 1# happyReduction_18 -happyReduction_18 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn7 - (RealDecl (SynDef happy_var_2 [] (RVar happy_var_3 happy_var_4 (mkhidden happy_var_2) Unknown)) - ) `HappyStk` happyRest}}} - -happyReduce_19 = happySpecReduce_2 1# happyReduction_19 -happyReduction_19 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> - happyIn7 - (RealDecl (CInclude happy_var_2) - )} - -happyReduce_20 = happySpecReduce_2 1# happyReduction_20 -happyReduction_20 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> - happyIn7 - (RealDecl (CLib happy_var_2) - )} - -happyReduce_21 = happyReduce 5# 2# happyReduction_21 -happyReduction_21 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - happyIn8 - (Transform happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_22 = happyReduce 7# 3# happyReduction_22 -happyReduction_22 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - case happyOut15 happy_x_5 of { happy_var_5 -> - case happyOut83 happy_x_6 of { happy_var_6 -> - case happyOut82 happy_x_7 of { happy_var_7 -> - happyIn9 - (FunType happy_var_1 happy_var_3 (nub happy_var_5) happy_var_6 happy_var_7 - ) `HappyStk` happyRest}}}}} - -happyReduce_23 = happySpecReduce_3 3# happyReduction_23 -happyReduction_23 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut79 happy_x_2 of { happy_var_2 -> - happyIn9 - (ProofScript happy_var_1 happy_var_2 - )}} - -happyReduce_24 = happyReduce 9# 3# happyReduction_24 -happyReduction_24 (happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_3 of { happy_var_3 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut14 happy_x_6 of { happy_var_6 -> - case happyOut83 happy_x_8 of { happy_var_8 -> - case happyOut82 happy_x_9 of { happy_var_9 -> - happyIn9 - (WithClause (mkDef happy_var_8 happy_var_9 happy_var_1) happy_var_2 happy_var_3 happy_var_4 happy_var_6 - ) `HappyStk` happyRest}}}}}}} - -happyReduce_25 = happyReduce 10# 3# happyReduction_25 -happyReduction_25 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut32 happy_x_7 of { happy_var_7 -> - case happyOut83 happy_x_9 of { happy_var_9 -> - case happyOut82 happy_x_10 of { happy_var_10 -> - happyIn9 - (FunClauseP (mkDef happy_var_9 happy_var_10 happy_var_1) happy_var_2 happy_var_4 happy_var_7 - ) `HappyStk` happyRest}}}}}} - -happyReduce_26 = happyReduce 8# 3# happyReduction_26 -happyReduction_26 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut15 happy_x_6 of { happy_var_6 -> - case happyOut83 happy_x_7 of { happy_var_7 -> - case happyOut82 happy_x_8 of { happy_var_8 -> - happyIn9 - (FunClause (mkDef happy_var_7 happy_var_8 happy_var_1) happy_var_2 happy_var_4 (nub happy_var_6) - ) `HappyStk` happyRest}}}}}} - -happyReduce_27 = happyReduce 5# 3# happyReduction_27 -happyReduction_27 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut13 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - happyIn9 - (FunClause RPlaceholder [happy_var_2] happy_var_4 [] - ) `HappyStk` happyRest}} - -happyReduce_28 = happyReduce 8# 3# happyReduction_28 -happyReduction_28 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut13 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut32 happy_x_7 of { happy_var_7 -> - happyIn9 - (FunClauseP RPlaceholder [happy_var_2] happy_var_4 happy_var_7 - ) `HappyStk` happyRest}}} - -happyReduce_29 = happyReduce 7# 3# happyReduction_29 -happyReduction_29 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut13 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_3 of { happy_var_3 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut14 happy_x_6 of { happy_var_6 -> - happyIn9 - (WithClause RPlaceholder [happy_var_2] happy_var_3 happy_var_4 happy_var_6 - ) `HappyStk` happyRest}}}} - -happyReduce_30 = happySpecReduce_1 4# happyReduction_30 -happyReduction_30 happy_x_1 - = happyIn10 - (Vis Public - ) - -happyReduce_31 = happySpecReduce_1 4# happyReduction_31 -happyReduction_31 happy_x_1 - = happyIn10 - (Vis Private - ) - -happyReduce_32 = happySpecReduce_1 4# happyReduction_32 -happyReduction_32 happy_x_1 - = happyIn10 - (Vis Abstract - ) - -happyReduce_33 = happySpecReduce_0 4# happyReduction_33 -happyReduction_33 = happyIn10 - (Vis Public - ) - -happyReduce_34 = happySpecReduce_1 5# happyReduction_34 -happyReduction_34 happy_x_1 - = happyIn11 - (False - ) - -happyReduce_35 = happySpecReduce_2 5# happyReduction_35 -happyReduction_35 happy_x_2 - happy_x_1 - = happyIn11 - (True - ) - -happyReduce_36 = happySpecReduce_3 6# happyReduction_36 -happyReduction_36 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut13 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn12 - (happy_var_2:happy_var_3 - )}} - -happyReduce_37 = happySpecReduce_0 6# happyReduction_37 -happyReduction_37 = happyIn12 - ([] - ) - -happyReduce_38 = happySpecReduce_1 7# happyReduction_38 -happyReduction_38 happy_x_1 - = case happyOut33 happy_x_1 of { happy_var_1 -> - happyIn13 - (happy_var_1 - )} - -happyReduce_39 = happySpecReduce_1 7# happyReduction_39 -happyReduction_39 happy_x_1 - = case happyOut58 happy_x_1 of { happy_var_1 -> - happyIn13 - (happy_var_1 - )} - -happyReduce_40 = happySpecReduce_3 7# happyReduction_40 -happyReduction_40 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn13 - (happy_var_2 - )} - -happyReduce_41 = happyReduce 5# 7# happyReduction_41 -happyReduction_41 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut59 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn13 - (pairDesugar happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "mkPair") Unknown) happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_42 = happySpecReduce_2 8# happyReduction_42 -happyReduction_42 happy_x_2 - happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut14 happy_x_2 of { happy_var_2 -> - happyIn14 - (happy_var_1:happy_var_2 - )}} - -happyReduce_43 = happySpecReduce_1 8# happyReduction_43 -happyReduction_43 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn14 - ([happy_var_1] - )} - -happyReduce_44 = happySpecReduce_3 9# happyReduction_44 -happyReduction_44 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut16 happy_x_2 of { happy_var_2 -> - happyIn15 - (happy_var_2 - )} - -happyReduce_45 = happySpecReduce_0 9# happyReduction_45 -happyReduction_45 = happyIn15 - ([] - ) - -happyReduce_46 = happySpecReduce_0 10# happyReduction_46 -happyReduction_46 = happyIn16 - ([] - ) - -happyReduce_47 = happySpecReduce_2 10# happyReduction_47 -happyReduction_47 happy_x_2 - happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - case happyOut16 happy_x_2 of { happy_var_2 -> - happyIn16 - (happy_var_1 ++ happy_var_2 - )}} - -happyReduce_48 = happySpecReduce_1 11# happyReduction_48 -happyReduction_48 happy_x_1 - = happyIn17 - ([NoCG] - ) - -happyReduce_49 = happySpecReduce_1 11# happyReduction_49 -happyReduction_49 happy_x_1 - = happyIn17 - ([CGEval, Inline] - ) - -happyReduce_50 = happyReduce 4# 11# happyReduction_50 -happyReduction_50 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut39 happy_x_3 of { happy_var_3 -> - happyIn17 - ([CGSpec happy_var_3] - ) `HappyStk` happyRest} - -happyReduce_51 = happySpecReduce_1 11# happyReduction_51 -happyReduction_51 happy_x_1 - = happyIn17 - ([CGSpec []] - ) - -happyReduce_52 = happySpecReduce_1 11# happyReduction_52 -happyReduction_52 happy_x_1 - = happyIn17 - ([Inline] - ) - -happyReduce_53 = happySpecReduce_2 11# happyReduction_53 -happyReduction_53 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> - happyIn17 - ([CExport happy_var_2] - )} - -happyReduce_54 = happyReduce 4# 12# happyReduction_54 -happyReduction_54 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut21 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokenInt happy_var_2) -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn18 - (map (\x -> Fixity x happy_var_1 happy_var_2) happy_var_3 - ) `HappyStk` happyRest}}} - -happyReduce_55 = happySpecReduce_1 13# happyReduction_55 -happyReduction_55 happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - happyIn19 - ([happy_var_1] - )} - -happyReduce_56 = happySpecReduce_3 13# happyReduction_56 -happyReduction_56 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn19 - (happy_var_1:happy_var_3 - )}} - -happyReduce_57 = happySpecReduce_1 14# happyReduction_57 -happyReduction_57 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenInfixName happy_var_1) -> - happyIn20 - (happy_var_1 - )} - -happyReduce_58 = happySpecReduce_1 14# happyReduction_58 -happyReduction_58 happy_x_1 - = happyIn20 - ("-" - ) - -happyReduce_59 = happySpecReduce_1 14# happyReduction_59 -happyReduction_59 happy_x_1 - = happyIn20 - ("<" - ) - -happyReduce_60 = happySpecReduce_1 14# happyReduction_60 -happyReduction_60 happy_x_1 - = happyIn20 - (">" - ) - -happyReduce_61 = happySpecReduce_1 15# happyReduction_61 -happyReduction_61 happy_x_1 - = happyIn21 - (LeftAssoc - ) - -happyReduce_62 = happySpecReduce_1 15# happyReduction_62 -happyReduction_62 happy_x_1 - = happyIn21 - (RightAssoc - ) - -happyReduce_63 = happySpecReduce_1 15# happyReduction_63 -happyReduction_63 happy_x_1 - = happyIn21 - (NonAssoc - ) - -happyReduce_64 = happyReduce 4# 16# happyReduction_64 -happyReduction_64 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut23 happy_x_3 of { happy_var_3 -> - happyIn22 - (LatexDefs happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_65 = happySpecReduce_3 17# happyReduction_65 -happyReduction_65 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_3 of { (TokenString happy_var_3) -> - happyIn23 - ([(happy_var_1,happy_var_3)] - )}} - -happyReduce_66 = happyReduce 5# 17# happyReduction_66 -happyReduction_66 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_3 of { (TokenString happy_var_3) -> - case happyOut23 happy_x_5 of { happy_var_5 -> - happyIn23 - ((happy_var_1,happy_var_3):happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_67 = happySpecReduce_2 18# happyReduction_67 -happyReduction_67 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut25 happy_x_2 of { happy_var_2 -> - happyIn24 - ((happy_var_1, happy_var_2) - )}} - -happyReduce_68 = happySpecReduce_0 19# happyReduction_68 -happyReduction_68 = happyIn25 - ([] - ) - -happyReduce_69 = happySpecReduce_2 19# happyReduction_69 -happyReduction_69 happy_x_2 - happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - case happyOut25 happy_x_2 of { happy_var_2 -> - happyIn25 - ((happy_var_1,Nothing):happy_var_2 - )}} - -happyReduce_70 = happyReduce 5# 19# happyReduction_70 -happyReduction_70 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokenBrackName happy_var_1) -> - case happyOut25 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn25 - ((RVar happy_var_4 happy_var_5 happy_var_1 Unknown, Just happy_var_1):happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_71 = happyReduce 5# 19# happyReduction_71 -happyReduction_71 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokenBrackName happy_var_1) -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut25 happy_x_5 of { happy_var_5 -> - happyIn25 - ((happy_var_3, Just happy_var_1):happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_72 = happyReduce 6# 20# happyReduction_72 -happyReduction_72 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut27 happy_x_1 of { happy_var_1 -> - case happyOut29 happy_x_2 of { happy_var_2 -> - case happyOut32 happy_x_3 of { happy_var_3 -> - case happyOut28 happy_x_4 of { happy_var_4 -> - case happyOut83 happy_x_5 of { happy_var_5 -> - case happyOut82 happy_x_6 of { happy_var_6 -> - happyIn26 - (mkDatatype happy_var_1 happy_var_5 happy_var_6 happy_var_3 happy_var_4 happy_var_2 - ) `HappyStk` happyRest}}}}}} - -happyReduce_73 = happySpecReduce_1 21# happyReduction_73 -happyReduction_73 happy_x_1 - = happyIn27 - (False - ) - -happyReduce_74 = happySpecReduce_1 21# happyReduction_74 -happyReduction_74 happy_x_1 - = happyIn27 - (True - ) - -happyReduce_75 = happySpecReduce_3 22# happyReduction_75 -happyReduction_75 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut66 happy_x_1 of { happy_var_1 -> - case happyOut75 happy_x_2 of { happy_var_2 -> - happyIn28 - (Right (happy_var_1,happy_var_2) - )}} - -happyReduce_76 = happySpecReduce_3 22# happyReduction_76 -happyReduction_76 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut50 happy_x_2 of { happy_var_2 -> - happyIn28 - (Left happy_var_2 - )} - -happyReduce_77 = happySpecReduce_3 22# happyReduction_77 -happyReduction_77 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn28 - (Left (RConst happy_var_2 happy_var_3 TYPE) - )}} - -happyReduce_78 = happySpecReduce_0 23# happyReduction_78 -happyReduction_78 = happyIn29 - ([] - ) - -happyReduce_79 = happySpecReduce_3 23# happyReduction_79 -happyReduction_79 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut30 happy_x_2 of { happy_var_2 -> - happyIn29 - (happy_var_2 - )} - -happyReduce_80 = happySpecReduce_1 24# happyReduction_80 -happyReduction_80 happy_x_1 - = case happyOut31 happy_x_1 of { happy_var_1 -> - happyIn30 - ([happy_var_1] - )} - -happyReduce_81 = happySpecReduce_3 24# happyReduction_81 -happyReduction_81 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut31 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 - (happy_var_1:happy_var_3 - )}} - -happyReduce_82 = happySpecReduce_1 25# happyReduction_82 -happyReduction_82 happy_x_1 - = happyIn31 - (NoElim - ) - -happyReduce_83 = happySpecReduce_1 25# happyReduction_83 -happyReduction_83 happy_x_1 - = happyIn31 - (Collapsible - ) - -happyReduce_84 = happySpecReduce_1 26# happyReduction_84 -happyReduction_84 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenName happy_var_1) -> - happyIn32 - (happy_var_1 - )} - -happyReduce_85 = happySpecReduce_3 26# happyReduction_85 -happyReduction_85 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut20 happy_x_2 of { happy_var_2 -> - happyIn32 - (useropFn happy_var_2 - )} - -happyReduce_86 = happyReduce 4# 27# happyReduction_86 -happyReduction_86 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut33 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - case happyOut57 happy_x_4 of { happy_var_4 -> - happyIn33 - (RApp happy_var_2 happy_var_3 happy_var_1 happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_87 = happyReduce 5# 27# happyReduction_87 -happyReduction_87 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut33 happy_x_1 of { happy_var_1 -> - case happyOut43 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn33 - (RAppImp happy_var_4 happy_var_5 (fst happy_var_2) happy_var_1 (snd happy_var_2) - ) `HappyStk` happyRest}}}} - -happyReduce_88 = happySpecReduce_3 27# happyReduction_88 -happyReduction_88 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn33 - (RVar happy_var_2 happy_var_3 happy_var_1 Unknown - )}}} - -happyReduce_89 = happySpecReduce_3 27# happyReduction_89 -happyReduction_89 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut64 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn33 - (RConst happy_var_2 happy_var_3 happy_var_1 - )}}} - -happyReduce_90 = happySpecReduce_1 27# happyReduction_90 -happyReduction_90 happy_x_1 - = happyIn33 - (RPlaceholder - ) - -happyReduce_91 = happySpecReduce_3 27# happyReduction_91 -happyReduction_91 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn33 - (RVar happy_var_2 happy_var_3 (UN "__Empty") TypeCon - )}} - -happyReduce_92 = happySpecReduce_3 27# happyReduction_92 -happyReduction_92 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn33 - (RVar happy_var_2 happy_var_3 (UN "__Unit") TypeCon - )}} - -happyReduce_93 = happySpecReduce_1 28# happyReduction_93 -happyReduction_93 happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - happyIn34 - (happy_var_1 - )} - -happyReduce_94 = happySpecReduce_3 28# happyReduction_94 -happyReduction_94 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut50 happy_x_2 of { happy_var_2 -> - happyIn34 - (happy_var_2 - )} - -happyReduce_95 = happyReduce 4# 28# happyReduction_95 -happyReduction_95 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - case happyOut57 happy_x_4 of { happy_var_4 -> - happyIn34 - (RApp happy_var_2 happy_var_3 happy_var_1 happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_96 = happyReduce 5# 28# happyReduction_96 -happyReduction_96 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut43 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn34 - (RAppImp happy_var_4 happy_var_5 (fst happy_var_2) happy_var_1 (snd happy_var_2) - ) `HappyStk` happyRest}}}} - -happyReduce_97 = happyReduce 4# 28# happyReduction_97 -happyReduction_97 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn34 - (RApp happy_var_3 happy_var_4 (RApp happy_var_3 happy_var_4 (RVar happy_var_3 happy_var_4 (UN "__lazy") Free) RPlaceholder) happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_98 = happyReduce 4# 28# happyReduction_98 -happyReduction_98 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut35 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - happyIn34 - (doBind Lam happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_99 = happyReduce 4# 28# happyReduction_99 -happyReduction_99 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut42 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - happyIn34 - (doLetBind happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_100 = happySpecReduce_1 28# happyReduction_100 -happyReduction_100 happy_x_1 - = case happyOut44 happy_x_1 of { happy_var_1 -> - happyIn34 - (happy_var_1 - )} - -happyReduce_101 = happyReduce 8# 28# happyReduction_101 -happyReduction_101 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut34 happy_x_6 of { happy_var_6 -> - case happyOut83 happy_x_7 of { happy_var_7 -> - case happyOut82 happy_x_8 of { happy_var_8 -> - happyIn34 - (mkApp happy_var_7 happy_var_8 (RVar happy_var_7 happy_var_8 (UN "if_then_else") Free) [happy_var_2,happy_var_4,happy_var_6] - ) `HappyStk` happyRest}}}}} - -happyReduce_102 = happySpecReduce_2 29# happyReduction_102 -happyReduction_102 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut48 happy_x_2 of { happy_var_2 -> - happyIn35 - ([(happy_var_1,happy_var_2)] - )}} - -happyReduce_103 = happyReduce 4# 29# happyReduction_103 -happyReduction_103 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut48 happy_x_2 of { happy_var_2 -> - case happyOut35 happy_x_4 of { happy_var_4 -> - happyIn35 - ((happy_var_1,happy_var_2):happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_104 = happySpecReduce_3 30# happyReduction_104 -happyReduction_104 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut36 happy_x_3 of { happy_var_3 -> - happyIn36 - (happy_var_1 ++ happy_var_3 - )}} - -happyReduce_105 = happySpecReduce_1 30# happyReduction_105 -happyReduction_105 happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - happyIn36 - (happy_var_1 - )} - -happyReduce_106 = happySpecReduce_3 31# happyReduction_106 -happyReduction_106 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn37 - (map ( \x -> (x,happy_var_3)) [happy_var_1] - )}} - -happyReduce_107 = happySpecReduce_1 32# happyReduction_107 -happyReduction_107 happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - happyIn38 - ([happy_var_1] - )} - -happyReduce_108 = happySpecReduce_3 32# happyReduction_108 -happyReduction_108 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut38 happy_x_3 of { happy_var_3 -> - happyIn38 - (happy_var_1:happy_var_3 - )}} - -happyReduce_109 = happySpecReduce_2 33# happyReduction_109 -happyReduction_109 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokenInt happy_var_2) -> - happyIn39 - ([(happy_var_1,happy_var_2)] - )}} - -happyReduce_110 = happySpecReduce_1 33# happyReduction_110 -happyReduction_110 happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - happyIn39 - ([(happy_var_1, 0)] - )} - -happyReduce_111 = happySpecReduce_3 33# happyReduction_111 -happyReduction_111 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut39 happy_x_3 of { happy_var_3 -> - happyIn39 - ((happy_var_1,0):happy_var_3 - )}} - -happyReduce_112 = happyReduce 4# 33# happyReduction_112 -happyReduction_112 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokenInt happy_var_2) -> - case happyOut39 happy_x_4 of { happy_var_4 -> - happyIn39 - ((happy_var_1,happy_var_2):happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_113 = happySpecReduce_1 34# happyReduction_113 -happyReduction_113 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenBrackName happy_var_1) -> - happyIn40 - ([happy_var_1] - )} - -happyReduce_114 = happySpecReduce_3 34# happyReduction_114 -happyReduction_114 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokenBrackName happy_var_1) -> - case happyOut38 happy_x_3 of { happy_var_3 -> - happyIn40 - (happy_var_1:happy_var_3 - )}} - -happyReduce_115 = happySpecReduce_0 35# happyReduction_115 -happyReduction_115 = happyIn41 - ([] - ) - -happyReduce_116 = happySpecReduce_2 35# happyReduction_116 -happyReduction_116 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut41 happy_x_2 of { happy_var_2 -> - happyIn41 - (happy_var_1:happy_var_2 - )}} - -happyReduce_117 = happyReduce 4# 36# happyReduction_117 -happyReduction_117 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut48 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - happyIn42 - ([(happy_var_1,happy_var_2,happy_var_4)] - ) `HappyStk` happyRest}}} - -happyReduce_118 = happyReduce 6# 36# happyReduction_118 -happyReduction_118 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut48 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut42 happy_x_6 of { happy_var_6 -> - happyIn42 - ((happy_var_1,happy_var_2,happy_var_4):happy_var_6 - ) `HappyStk` happyRest}}}} - -happyReduce_119 = happySpecReduce_3 37# happyReduction_119 -happyReduction_119 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokenBrackName happy_var_1) -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn43 - ((happy_var_1, RVar happy_var_2 happy_var_3 happy_var_1 Unknown) - )}}} - -happyReduce_120 = happySpecReduce_3 37# happyReduction_120 -happyReduction_120 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokenBrackName happy_var_1) -> - case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn43 - ((happy_var_1, happy_var_3) - )}} - -happyReduce_121 = happyReduce 4# 38# happyReduction_121 -happyReduction_121 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn44 - (RInfix happy_var_3 happy_var_4 Minus (RConst happy_var_3 happy_var_4 (Num 0)) happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_122 = happyReduce 5# 38# happyReduction_122 -happyReduction_122 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn44 - (RUserInfix happy_var_4 happy_var_5 False "-" happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_123 = happyReduce 5# 38# happyReduction_123 -happyReduction_123 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn44 - (mkApp happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "Pair") TypeCon) [happy_var_1, happy_var_3] - ) `HappyStk` happyRest}}}} - -happyReduce_124 = happyReduce 5# 38# happyReduction_124 -happyReduction_124 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn44 - (RUserInfix happy_var_4 happy_var_5 False "<" happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_125 = happyReduce 5# 38# happyReduction_125 -happyReduction_125 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn44 - (RUserInfix happy_var_4 happy_var_5 False ">" happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_126 = happyReduce 5# 38# happyReduction_126 -happyReduction_126 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn44 - (RBind (MN "X" 0) (Pi Ex [] happy_var_1) happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_127 = happySpecReduce_1 38# happyReduction_127 -happyReduction_127 happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - happyIn44 - (happy_var_1 - )} - -happyReduce_128 = happyReduce 5# 38# happyReduction_128 -happyReduction_128 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut57 happy_x_1 of { happy_var_1 -> - case happyOut57 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn44 - (RInfix happy_var_4 happy_var_5 JMEq happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_129 = happyReduce 5# 39# happyReduction_129 -happyReduction_129 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokenInfixName happy_var_2) -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn45 - (RUserInfix happy_var_4 happy_var_5 False happy_var_2 happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}}} - -happyReduce_130 = happyReduce 6# 40# happyReduction_130 -happyReduction_130 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokenInfixName happy_var_2) -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix happy_var_4 happy_var_5 False happy_var_2 (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown) happy_var_3) - ) `HappyStk` happyRest}}}} - -happyReduce_131 = happyReduce 6# 40# happyReduction_131 -happyReduction_131 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { (TokenInfixName happy_var_3) -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix happy_var_4 happy_var_5 False happy_var_3 happy_var_2 (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown)) - ) `HappyStk` happyRest}}}} - -happyReduce_132 = happyReduce 6# 40# happyReduction_132 -happyReduction_132 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut47 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix happy_var_4 happy_var_5 False happy_var_2 (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown) happy_var_3) - ) `HappyStk` happyRest}}}} - -happyReduce_133 = happyReduce 6# 40# happyReduction_133 -happyReduction_133 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix happy_var_4 happy_var_5 False happy_var_3 happy_var_2 (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown)) - ) `HappyStk` happyRest}}}} - -happyReduce_134 = happyReduce 6# 40# happyReduction_134 -happyReduction_134 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RUserInfix happy_var_4 happy_var_5 False "-" happy_var_2 (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown)) - ) `HappyStk` happyRest}}} - -happyReduce_135 = happyReduce 6# 40# happyReduction_135 -happyReduction_135 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RBind (MN "X" 1) (Pi Ex [] happy_var_2) (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown)) - ) `HappyStk` happyRest}}} - -happyReduce_136 = happyReduce 6# 40# happyReduction_136 -happyReduction_136 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RBind (MN "X" 1) (Pi Ex [] (RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown)) happy_var_3) - ) `HappyStk` happyRest}}} - -happyReduce_137 = happyReduce 5# 40# happyReduction_137 -happyReduction_137 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RBind (MN "X" 1) (Lam RPlaceholder) - (RBind (MN "X" 2) (Pi Ex [] (RVar happy_var_3 happy_var_4 (MN "X" 0) Unknown)) - (RVar happy_var_3 happy_var_4 (MN "X" 1) Unknown))) - ) `HappyStk` happyRest}} - -happyReduce_138 = happyReduce 5# 40# happyReduction_138 -happyReduction_138 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (RBind (MN "X" 1) (Lam RPlaceholder) - (pairDesugar happy_var_3 happy_var_4 (RVar happy_var_3 happy_var_4 (UN "mkPair") DataCon) - [RVar happy_var_3 happy_var_4 (MN "X" 0) Unknown, - RVar happy_var_3 happy_var_4 (MN "X" 1) Unknown])) - ) `HappyStk` happyRest}} - -happyReduce_139 = happyReduce 6# 40# happyReduction_139 -happyReduction_139 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (pairDesugar happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "mkPair") DataCon) - [happy_var_2, - RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown]) - ) `HappyStk` happyRest}}} - -happyReduce_140 = happyReduce 6# 40# happyReduction_140 -happyReduction_140 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn46 - (RBind (MN "X" 0) (Lam RPlaceholder) - (pairDesugar happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "mkPair") DataCon) - [RVar happy_var_4 happy_var_5 (MN "X" 0) Unknown, happy_var_3]) - ) `HappyStk` happyRest}}} - -happyReduce_141 = happySpecReduce_1 41# happyReduction_141 -happyReduction_141 happy_x_1 - = happyIn47 - ("<" - ) - -happyReduce_142 = happySpecReduce_1 41# happyReduction_142 -happyReduction_142 happy_x_1 - = happyIn47 - (">" - ) - -happyReduce_143 = happySpecReduce_0 42# happyReduction_143 -happyReduction_143 = happyIn48 - (RPlaceholder - ) - -happyReduce_144 = happySpecReduce_2 42# happyReduction_144 -happyReduction_144 happy_x_2 - happy_x_1 - = case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn48 - (happy_var_2 - )} - -happyReduce_145 = happySpecReduce_0 43# happyReduction_145 -happyReduction_145 = happyIn49 - (RPlaceholder - ) - -happyReduce_146 = happySpecReduce_2 43# happyReduction_146 -happyReduction_146 happy_x_2 - happy_x_1 - = case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn49 - (happy_var_2 - )} - -happyReduce_147 = happyReduce 5# 44# happyReduction_147 -happyReduction_147 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut49 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_5 of { happy_var_5 -> - happyIn50 - (doBind (Pi Im []) (map (\x -> (x, happy_var_2)) happy_var_1) happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_148 = happySpecReduce_1 44# happyReduction_148 -happyReduction_148 happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - happyIn50 - (happy_var_1 - )} - -happyReduce_149 = happySpecReduce_3 45# happyReduction_149 -happyReduction_149 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_3 of { happy_var_3 -> - happyIn51 - (RBind (MN "X" 0) (Pi Ex [] happy_var_1) happy_var_3 - )}} - -happyReduce_150 = happyReduce 6# 45# happyReduction_150 -happyReduction_150 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut36 happy_x_2 of { happy_var_2 -> - case happyOut53 happy_x_4 of { happy_var_4 -> - case happyOut51 happy_x_6 of { happy_var_6 -> - happyIn51 - (doBind (Pi Ex happy_var_4) happy_var_2 happy_var_6 - ) `HappyStk` happyRest}}} - -happyReduce_151 = happyReduce 5# 45# happyReduction_151 -happyReduction_151 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut36 happy_x_2 of { happy_var_2 -> - case happyOut51 happy_x_5 of { happy_var_5 -> - happyIn51 - (doBind (Pi Ex [Lazy]) happy_var_2 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_152 = happySpecReduce_3 45# happyReduction_152 -happyReduction_152 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn51 - (bracket happy_var_2 - )} - -happyReduce_153 = happyReduce 7# 45# happyReduction_153 -happyReduction_153 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut51 happy_x_2 of { happy_var_2 -> - case happyOut51 happy_x_4 of { happy_var_4 -> - case happyOut83 happy_x_5 of { happy_var_5 -> - case happyOut82 happy_x_6 of { happy_var_6 -> - happyIn51 - (RInfix happy_var_5 happy_var_6 JMEq happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_154 = happySpecReduce_1 45# happyReduction_154 -happyReduction_154 happy_x_1 - = case happyOut33 happy_x_1 of { happy_var_1 -> - happyIn51 - (happy_var_1 - )} - -happyReduce_155 = happySpecReduce_3 45# happyReduction_155 -happyReduction_155 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn51 - (happy_var_2 - )} - -happyReduce_156 = happyReduce 5# 45# happyReduction_156 -happyReduction_156 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokenInfixName happy_var_2) -> - case happyOut51 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn51 - (RUserInfix happy_var_4 happy_var_5 False happy_var_2 happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}}} - -happyReduce_157 = happyReduce 5# 45# happyReduction_157 -happyReduction_157 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_3 of { happy_var_3 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn51 - (RUserInfix happy_var_4 happy_var_5 False "-" happy_var_1 happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_158 = happyReduce 5# 45# happyReduction_158 -happyReduction_158 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut56 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn51 - (pairDesugar happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "Pair") TypeCon) happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_159 = happySpecReduce_1 45# happyReduction_159 -happyReduction_159 happy_x_1 - = case happyOut55 happy_x_1 of { happy_var_1 -> - happyIn51 - (happy_var_1 - )} - -happyReduce_160 = happySpecReduce_1 46# happyReduction_160 -happyReduction_160 happy_x_1 - = happyIn52 - (Lazy - ) - -happyReduce_161 = happySpecReduce_1 46# happyReduction_161 -happyReduction_161 happy_x_1 - = happyIn52 - (Static - ) - -happyReduce_162 = happySpecReduce_3 47# happyReduction_162 -happyReduction_162 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut54 happy_x_2 of { happy_var_2 -> - happyIn53 - (happy_var_2 - )} - -happyReduce_163 = happySpecReduce_0 47# happyReduction_163 -happyReduction_163 = happyIn53 - ([] - ) - -happyReduce_164 = happySpecReduce_3 48# happyReduction_164 -happyReduction_164 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut52 happy_x_1 of { happy_var_1 -> - case happyOut54 happy_x_3 of { happy_var_3 -> - happyIn54 - (happy_var_1:happy_var_3 - )}} - -happyReduce_165 = happySpecReduce_1 48# happyReduction_165 -happyReduction_165 happy_x_1 - = case happyOut52 happy_x_1 of { happy_var_1 -> - happyIn54 - ([happy_var_1] - )} - -happyReduce_166 = happyReduce 8# 49# happyReduction_166 -happyReduction_166 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut51 happy_x_5 of { happy_var_5 -> - case happyOut83 happy_x_7 of { happy_var_7 -> - case happyOut82 happy_x_8 of { happy_var_8 -> - happyIn55 - (sigDesugar happy_var_7 happy_var_8 (happy_var_2, happy_var_3) happy_var_5 - ) `HappyStk` happyRest}}}}} - -happyReduce_167 = happySpecReduce_3 50# happyReduction_167 -happyReduction_167 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_3 of { happy_var_3 -> - happyIn56 - (happy_var_1:happy_var_3:[] - )}} - -happyReduce_168 = happySpecReduce_3 50# happyReduction_168 -happyReduction_168 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut56 happy_x_3 of { happy_var_3 -> - happyIn56 - (happy_var_1:happy_var_3 - )}} - -happyReduce_169 = happySpecReduce_3 51# happyReduction_169 -happyReduction_169 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn57 - (RVar happy_var_2 happy_var_3 happy_var_1 Unknown - )}}} - -happyReduce_170 = happySpecReduce_3 51# happyReduction_170 -happyReduction_170 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn57 - (RReturn happy_var_2 happy_var_3 - )}} - -happyReduce_171 = happySpecReduce_3 51# happyReduction_171 -happyReduction_171 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn57 - (bracket happy_var_2 - )} - -happyReduce_172 = happySpecReduce_2 51# happyReduction_172 -happyReduction_172 happy_x_2 - happy_x_1 - = case happyOut57 happy_x_2 of { happy_var_2 -> - happyIn57 - (RPure happy_var_2 - )} - -happyReduce_173 = happySpecReduce_1 51# happyReduction_173 -happyReduction_173 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenMetavar happy_var_1) -> - happyIn57 - (RMetavar happy_var_1 - )} - -happyReduce_174 = happyReduce 4# 51# happyReduction_174 -happyReduction_174 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn57 - (RMetavarPrf (UN "") happy_var_3 False - ) `HappyStk` happyRest} - -happyReduce_175 = happyReduce 4# 51# happyReduction_175 -happyReduction_175 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn57 - (RMetavarPrf (UN "") happy_var_3 True - ) `HappyStk` happyRest} - -happyReduce_176 = happyReduce 4# 51# happyReduction_176 -happyReduction_176 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn57 - (RExpVar happy_var_3 happy_var_4 happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_177 = happySpecReduce_3 51# happyReduction_177 -happyReduction_177 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut64 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn57 - (RConst happy_var_2 happy_var_3 happy_var_1 - )}}} - -happyReduce_178 = happySpecReduce_1 51# happyReduction_178 -happyReduction_178 happy_x_1 - = happyIn57 - (RRefl - ) - -happyReduce_179 = happySpecReduce_3 51# happyReduction_179 -happyReduction_179 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn57 - (RVar happy_var_2 happy_var_3 (UN "__Empty") TypeCon - )}} - -happyReduce_180 = happySpecReduce_3 51# happyReduction_180 -happyReduction_180 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn57 - (RVar happy_var_2 happy_var_3 (UN "__Unit") TypeCon - )}} - -happyReduce_181 = happySpecReduce_1 51# happyReduction_181 -happyReduction_181 happy_x_1 - = happyIn57 - (RPlaceholder - ) - -happyReduce_182 = happySpecReduce_1 51# happyReduction_182 -happyReduction_182 happy_x_1 - = case happyOut61 happy_x_1 of { happy_var_1 -> - happyIn57 - (RDo happy_var_1 - )} - -happyReduce_183 = happySpecReduce_3 51# happyReduction_183 -happyReduction_183 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn57 - (RIdiom happy_var_2 - )} - -happyReduce_184 = happyReduce 5# 51# happyReduction_184 -happyReduction_184 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut59 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn57 - (pairDesugar happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "mkPair") DataCon) happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_185 = happySpecReduce_1 51# happyReduction_185 -happyReduction_185 happy_x_1 - = case happyOut55 happy_x_1 of { happy_var_1 -> - happyIn57 - (happy_var_1 - )} - -happyReduce_186 = happySpecReduce_1 51# happyReduction_186 -happyReduction_186 happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - happyIn57 - (happy_var_1 - )} - -happyReduce_187 = happySpecReduce_1 51# happyReduction_187 -happyReduction_187 happy_x_1 - = case happyOut58 happy_x_1 of { happy_var_1 -> - happyIn57 - (happy_var_1 - )} - -happyReduce_188 = happyReduce 5# 51# happyReduction_188 -happyReduction_188 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - case happyOut60 happy_x_4 of { happy_var_4 -> - happyIn57 - (mkConsList happy_var_2 happy_var_3 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_189 = happyReduce 7# 52# happyReduction_189 -happyReduction_189 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut83 happy_x_6 of { happy_var_6 -> - case happyOut82 happy_x_7 of { happy_var_7 -> - happyIn58 - (RApp happy_var_6 happy_var_7 (RApp happy_var_6 happy_var_7 (RVar happy_var_6 happy_var_7 (UN "Exists") DataCon) happy_var_2) happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_190 = happyReduce 5# 52# happyReduction_190 -happyReduction_190 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut83 happy_x_4 of { happy_var_4 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn58 - (RApp happy_var_4 happy_var_5 (RApp happy_var_4 happy_var_5 (RVar happy_var_4 happy_var_5 (UN "Exists") DataCon) RPlaceholder) happy_var_2 - ) `HappyStk` happyRest}}} - -happyReduce_191 = happySpecReduce_3 53# happyReduction_191 -happyReduction_191 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn59 - (happy_var_1:happy_var_3:[] - )}} - -happyReduce_192 = happySpecReduce_3 53# happyReduction_192 -happyReduction_192 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - happyIn59 - (happy_var_1:happy_var_3 - )}} - -happyReduce_193 = happySpecReduce_0 54# happyReduction_193 -happyReduction_193 = happyIn60 - ([] - ) - -happyReduce_194 = happySpecReduce_1 54# happyReduction_194 -happyReduction_194 happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - happyIn60 - ([happy_var_1] - )} - -happyReduce_195 = happySpecReduce_3 54# happyReduction_195 -happyReduction_195 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut60 happy_x_3 of { happy_var_3 -> - happyIn60 - (happy_var_1:happy_var_3 - )}} - -happyReduce_196 = happyReduce 4# 55# happyReduction_196 -happyReduction_196 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut62 happy_x_3 of { happy_var_3 -> - happyIn61 - (happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_197 = happyReduce 10# 55# happyReduction_197 -happyReduction_197 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokenBrackName happy_var_2) -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut34 happy_x_5 of { happy_var_5 -> - case happyOut83 happy_x_6 of { happy_var_6 -> - case happyOut82 happy_x_7 of { happy_var_7 -> - case happyOut62 happy_x_9 of { happy_var_9 -> - happyIn61 - (DoBinding happy_var_6 happy_var_7 happy_var_2 happy_var_3 happy_var_5 : happy_var_9 - ) `HappyStk` happyRest}}}}}} - -happyReduce_198 = happySpecReduce_2 56# happyReduction_198 -happyReduction_198 happy_x_2 - happy_x_1 - = case happyOut63 happy_x_1 of { happy_var_1 -> - case happyOut62 happy_x_2 of { happy_var_2 -> - happyIn62 - (happy_var_1:happy_var_2 - )}} - -happyReduce_199 = happySpecReduce_1 56# happyReduction_199 -happyReduction_199 happy_x_1 - = case happyOut63 happy_x_1 of { happy_var_1 -> - happyIn62 - ([happy_var_1] - )} - -happyReduce_200 = happyReduce 7# 57# happyReduction_200 -happyReduction_200 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut48 happy_x_2 of { happy_var_2 -> - case happyOut34 happy_x_4 of { happy_var_4 -> - case happyOut83 happy_x_5 of { happy_var_5 -> - case happyOut82 happy_x_6 of { happy_var_6 -> - happyIn63 - (DoBinding happy_var_5 happy_var_6 happy_var_1 happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}}}} - -happyReduce_201 = happyReduce 8# 57# happyReduction_201 -happyReduction_201 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut34 happy_x_5 of { happy_var_5 -> - case happyOut83 happy_x_6 of { happy_var_6 -> - case happyOut82 happy_x_7 of { happy_var_7 -> - happyIn63 - (DoLet happy_var_6 happy_var_7 happy_var_2 happy_var_3 happy_var_5 - ) `HappyStk` happyRest}}}}} - -happyReduce_202 = happyReduce 4# 57# happyReduction_202 -happyReduction_202 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn63 - (DoExp happy_var_2 happy_var_3 happy_var_1 - ) `HappyStk` happyRest}}} - -happyReduce_203 = happySpecReduce_1 58# happyReduction_203 -happyReduction_203 happy_x_1 - = happyIn64 - (TYPE - ) - -happyReduce_204 = happySpecReduce_1 58# happyReduction_204 -happyReduction_204 happy_x_1 - = happyIn64 - (LTYPE - ) - -happyReduce_205 = happySpecReduce_1 58# happyReduction_205 -happyReduction_205 happy_x_1 - = happyIn64 - (StringType - ) - -happyReduce_206 = happySpecReduce_1 58# happyReduction_206 -happyReduction_206 happy_x_1 - = happyIn64 - (IntType - ) - -happyReduce_207 = happySpecReduce_1 58# happyReduction_207 -happyReduction_207 happy_x_1 - = happyIn64 - (CharType - ) - -happyReduce_208 = happySpecReduce_1 58# happyReduction_208 -happyReduction_208 happy_x_1 - = happyIn64 - (FloatType - ) - -happyReduce_209 = happySpecReduce_1 58# happyReduction_209 -happyReduction_209 happy_x_1 - = happyIn64 - (PtrType - ) - -happyReduce_210 = happySpecReduce_1 58# happyReduction_210 -happyReduction_210 happy_x_1 - = happyIn64 - (Builtin "Handle" - ) - -happyReduce_211 = happySpecReduce_1 58# happyReduction_211 -happyReduction_211 happy_x_1 - = happyIn64 - (Builtin "Lock" - ) - -happyReduce_212 = happySpecReduce_1 58# happyReduction_212 -happyReduction_212 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenInt happy_var_1) -> - happyIn64 - (Num happy_var_1 - )} - -happyReduce_213 = happySpecReduce_1 58# happyReduction_213 -happyReduction_213 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenChar happy_var_1) -> - happyIn64 - (Ch happy_var_1 - )} - -happyReduce_214 = happySpecReduce_1 58# happyReduction_214 -happyReduction_214 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenString happy_var_1) -> - happyIn64 - (Str happy_var_1 - )} - -happyReduce_215 = happySpecReduce_1 58# happyReduction_215 -happyReduction_215 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenBool happy_var_1) -> - happyIn64 - (Bo happy_var_1 - )} - -happyReduce_216 = happySpecReduce_1 58# happyReduction_216 -happyReduction_216 happy_x_1 - = case happyOutTok happy_x_1 of { (TokenFloat happy_var_1) -> - happyIn64 - (Fl happy_var_1 - )} - -happyReduce_217 = happySpecReduce_0 59# happyReduction_217 -happyReduction_217 = happyIn65 - ([] - ) - -happyReduce_218 = happySpecReduce_2 59# happyReduction_218 -happyReduction_218 happy_x_2 - happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - case happyOut65 happy_x_2 of { happy_var_2 -> - happyIn65 - (happy_var_1:happy_var_2 - )}} - -happyReduce_219 = happyReduce 4# 60# happyReduction_219 -happyReduction_219 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut50 happy_x_2 of { happy_var_2 -> - case happyOut67 happy_x_3 of { happy_var_3 -> - happyIn66 - ((happy_var_2, happy_var_3) - ) `HappyStk` happyRest}} - -happyReduce_220 = happySpecReduce_3 60# happyReduction_220 -happyReduction_220 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn66 - ((RConst happy_var_2 happy_var_3 TYPE, []) - )}} - -happyReduce_221 = happyReduce 4# 60# happyReduction_221 -happyReduction_221 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut73 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn66 - ((mkTyParams happy_var_3 happy_var_4 happy_var_1, []) - ) `HappyStk` happyRest}}} - -happyReduce_222 = happySpecReduce_0 61# happyReduction_222 -happyReduction_222 = happyIn67 - ([] - ) - -happyReduce_223 = happyReduce 4# 61# happyReduction_223 -happyReduction_223 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut72 happy_x_3 of { happy_var_3 -> - happyIn67 - (happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_224 = happyReduce 7# 62# happyReduction_224 -happyReduction_224 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_4 of { happy_var_4 -> - case happyOut32 happy_x_6 of { happy_var_6 -> - happyIn68 - ((happy_var_4,happy_var_6) - ) `HappyStk` happyRest}} - -happyReduce_225 = happyReduce 6# 63# happyReduction_225 -happyReduction_225 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_3 of { happy_var_3 -> - case happyOut32 happy_x_5 of { happy_var_5 -> - happyIn69 - ((happy_var_3,happy_var_5) - ) `HappyStk` happyRest}} - -happyReduce_226 = happyReduce 4# 64# happyReduction_226 -happyReduction_226 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut72 happy_x_3 of { happy_var_3 -> - happyIn70 - (happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_227 = happySpecReduce_2 65# happyReduction_227 -happyReduction_227 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_2 of { happy_var_2 -> - happyIn71 - (happy_var_2 - )} - -happyReduce_228 = happySpecReduce_3 66# happyReduction_228 -happyReduction_228 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn72 - ([(happy_var_1, happy_var_3)] - )}} - -happyReduce_229 = happyReduce 5# 66# happyReduction_229 -happyReduction_229 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - case happyOut72 happy_x_5 of { happy_var_5 -> - happyIn72 - ((happy_var_1,happy_var_3):happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_230 = happySpecReduce_1 67# happyReduction_230 -happyReduction_230 happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - happyIn73 - ([happy_var_1] - )} - -happyReduce_231 = happySpecReduce_2 67# happyReduction_231 -happyReduction_231 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut73 happy_x_2 of { happy_var_2 -> - happyIn73 - (happy_var_1:happy_var_2 - )}} - -happyReduce_232 = happySpecReduce_1 68# happyReduction_232 -happyReduction_232 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn74 - (happy_var_1 - )} - -happyReduce_233 = happySpecReduce_1 68# happyReduction_233 -happyReduction_233 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn74 - (happy_var_1 - )} - -happyReduce_234 = happySpecReduce_0 69# happyReduction_234 -happyReduction_234 = happyIn75 - ([] - ) - -happyReduce_235 = happySpecReduce_1 69# happyReduction_235 -happyReduction_235 happy_x_1 - = case happyOut76 happy_x_1 of { happy_var_1 -> - happyIn75 - ([happy_var_1] - )} - -happyReduce_236 = happySpecReduce_3 69# happyReduction_236 -happyReduction_236 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut76 happy_x_1 of { happy_var_1 -> - case happyOut75 happy_x_3 of { happy_var_3 -> - happyIn75 - (happy_var_1:happy_var_3 - )}} - -happyReduce_237 = happySpecReduce_2 70# happyReduction_237 -happyReduction_237 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut77 happy_x_2 of { happy_var_2 -> - happyIn76 - (Full happy_var_1 happy_var_2 - )}} - -happyReduce_238 = happySpecReduce_2 70# happyReduction_238 -happyReduction_238 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut65 happy_x_2 of { happy_var_2 -> - happyIn76 - (Simple happy_var_1 happy_var_2 - )}} - -happyReduce_239 = happySpecReduce_2 71# happyReduction_239 -happyReduction_239 happy_x_2 - happy_x_1 - = case happyOut50 happy_x_2 of { happy_var_2 -> - happyIn77 - (happy_var_2 - )} - -happyReduce_240 = happySpecReduce_2 72# happyReduction_240 -happyReduction_240 happy_x_2 - happy_x_1 - = case happyOut38 happy_x_2 of { happy_var_2 -> - happyIn78 - (Intro happy_var_2 - )} - -happyReduce_241 = happySpecReduce_1 72# happyReduction_241 -happyReduction_241 happy_x_1 - = happyIn78 - (Intro [] - ) - -happyReduce_242 = happySpecReduce_2 72# happyReduction_242 -happyReduction_242 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_2 of { happy_var_2 -> - happyIn78 - (Refine happy_var_2 - )} - -happyReduce_243 = happySpecReduce_2 72# happyReduction_243 -happyReduction_243 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Exists happy_var_2 - )} - -happyReduce_244 = happySpecReduce_2 72# happyReduction_244 -happyReduction_244 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Generalise happy_var_2 - )} - -happyReduce_245 = happySpecReduce_1 72# happyReduction_245 -happyReduction_245 happy_x_1 - = happyIn78 - (ReflP - ) - -happyReduce_246 = happySpecReduce_2 72# happyReduction_246 -happyReduction_246 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Rewrite False False happy_var_2 - )} - -happyReduce_247 = happySpecReduce_3 72# happyReduction_247 -happyReduction_247 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn78 - (Rewrite False True happy_var_3 - )} - -happyReduce_248 = happySpecReduce_2 72# happyReduction_248 -happyReduction_248 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Rewrite True False happy_var_2 - )} - -happyReduce_249 = happySpecReduce_3 72# happyReduction_249 -happyReduction_249 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn78 - (Rewrite True True happy_var_3 - )} - -happyReduce_250 = happySpecReduce_1 72# happyReduction_250 -happyReduction_250 happy_x_1 - = happyIn78 - (Compute - ) - -happyReduce_251 = happySpecReduce_2 72# happyReduction_251 -happyReduction_251 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_2 of { happy_var_2 -> - happyIn78 - (Unfold happy_var_2 - )} - -happyReduce_252 = happySpecReduce_1 72# happyReduction_252 -happyReduction_252 happy_x_1 - = happyIn78 - (Undo - ) - -happyReduce_253 = happySpecReduce_2 72# happyReduction_253 -happyReduction_253 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Induction happy_var_2 - )} - -happyReduce_254 = happySpecReduce_2 72# happyReduction_254 -happyReduction_254 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Fill happy_var_2 - )} - -happyReduce_255 = happySpecReduce_1 72# happyReduction_255 -happyReduction_255 happy_x_1 - = happyIn78 - (Trivial - ) - -happyReduce_256 = happySpecReduce_1 72# happyReduction_256 -happyReduction_256 happy_x_1 - = happyIn78 - (SimpleSearch - ) - -happyReduce_257 = happySpecReduce_2 72# happyReduction_257 -happyReduction_257 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (RunTactic happy_var_2 - )} - -happyReduce_258 = happySpecReduce_2 72# happyReduction_258 -happyReduction_258 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Believe happy_var_2 - )} - -happyReduce_259 = happySpecReduce_2 72# happyReduction_259 -happyReduction_259 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Use happy_var_2 - )} - -happyReduce_260 = happySpecReduce_2 72# happyReduction_260 -happyReduction_260 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn78 - (Decide happy_var_2 - )} - -happyReduce_261 = happySpecReduce_1 72# happyReduction_261 -happyReduction_261 happy_x_1 - = happyIn78 - (Abandon - ) - -happyReduce_262 = happySpecReduce_1 72# happyReduction_262 -happyReduction_262 happy_x_1 - = happyIn78 - (ProofTerm - ) - -happyReduce_263 = happySpecReduce_1 72# happyReduction_263 -happyReduction_263 happy_x_1 - = happyIn78 - (Qed - ) - -happyReduce_264 = happyReduce 4# 73# happyReduction_264 -happyReduction_264 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn79 - (happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_265 = happySpecReduce_2 74# happyReduction_265 -happyReduction_265 happy_x_2 - happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - happyIn80 - ([happy_var_1] - )} - -happyReduce_266 = happySpecReduce_1 74# happyReduction_266 -happyReduction_266 happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - happyIn80 - ([happy_var_1] - )} - -happyReduce_267 = happySpecReduce_3 74# happyReduction_267 -happyReduction_267 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn80 - (happy_var_1:happy_var_3 - )}} - -happyReduce_268 = happySpecReduce_1 75# happyReduction_268 -happyReduction_268 happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - happyIn81 - ([happy_var_1] - )} - -happyReduce_269 = happySpecReduce_3 75# happyReduction_269 -happyReduction_269 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn81 - (happy_var_1:happy_var_3 - )}} - -happyReduce_270 = happyMonadReduce 0# 76# happyReduction_270 -happyReduction_270 (happyRest) tk - = happyThen (( getLineNo) - ) (\r -> happyReturn (happyIn82 r)) - -happyReduce_271 = happyMonadReduce 0# 77# happyReduction_271 -happyReduction_271 (happyRest) tk - = happyThen (( getFileName) - ) (\r -> happyReturn (happyIn83 r)) - -happyReduce_272 = happyMonadReduce 0# 78# happyReduction_272 -happyReduction_272 (happyRest) tk - = happyThen (( getOps) - ) (\r -> happyReturn (happyIn84 r)) - -happyNewToken action sts stk - = lexer(\tk -> - let cont i = happyDoAction i tk action sts stk in - case tk of { - TokenEOF -> happyDoAction 125# tk action sts stk; - TokenName happy_dollar_dollar -> cont 1#; - TokenInfixName happy_dollar_dollar -> cont 2#; - TokenBrackName happy_dollar_dollar -> cont 3#; - TokenString happy_dollar_dollar -> cont 4#; - TokenInt happy_dollar_dollar -> cont 5#; - TokenFloat happy_dollar_dollar -> cont 6#; - TokenChar happy_dollar_dollar -> cont 7#; - TokenBool happy_dollar_dollar -> cont 8#; - TokenMetavar happy_dollar_dollar -> cont 9#; - TokenColon -> cont 10#; - TokenSemi -> cont 11#; - TokenBar -> cont 12#; - TokenStars -> cont 13#; - TokenLambda -> cont 14#; - TokenHashOB -> cont 15#; - TokenOB -> cont 16#; - TokenCB -> cont 17#; - TokenOCB -> cont 18#; - TokenCCB -> cont 19#; - TokenOSB -> cont 20#; - TokenCSB -> cont 21#; - TokenOId -> cont 22#; - TokenCId -> cont 23#; - TokenLPair -> cont 24#; - TokenRPair -> cont 25#; - TokenExists -> cont 26#; - TokenTilde -> cont 27#; - TokenPlus -> cont 28#; - TokenMinus -> cont 29#; - TokenTimes -> cont 30#; - TokenDivide -> cont 31#; - TokenEquals -> cont 32#; - TokenMightEqual -> cont 33#; - TokenLT -> cont 34#; - TokenGT -> cont 35#; - TokenEllipsis -> cont 36#; - TokenUnderscore -> cont 37#; - TokenComma -> cont 38#; - TokenTuple -> cont 39#; - TokenBang -> cont 40#; - TokenConcat -> cont 41#; - TokenGE -> cont 42#; - TokenLE -> cont 43#; - TokenOr -> cont 44#; - TokenAnd -> cont 45#; - TokenArrow -> cont 46#; - TokenFatArrow -> cont 47#; - TokenTransArrow -> cont 48#; - TokenLeftArrow -> cont 49#; - TokenIntType -> cont 50#; - TokenCharType -> cont 51#; - TokenFloatType -> cont 52#; - TokenStringType -> cont 53#; - TokenHandleType -> cont 54#; - TokenPtrType -> cont 55#; - TokenLockType -> cont 56#; - TokenType -> cont 57#; - TokenLType -> cont 58#; - TokenLazyBracket -> cont 59#; - TokenDataType -> cont 60#; - TokenCoDataType -> cont 61#; - TokenInfix -> cont 62#; - TokenInfixL -> cont 63#; - TokenInfixR -> cont 64#; - TokenUsing -> cont 65#; - TokenIdiom -> cont 66#; - TokenParams -> cont 67#; - TokenNamespace -> cont 68#; - TokenPublic -> cont 69#; - TokenPrivate -> cont 70#; - TokenAbstract -> cont 71#; - TokenNoElim -> cont 72#; - TokenCollapsible -> cont 73#; - TokenWhere -> cont 74#; - TokenWith -> cont 75#; - TokenPartial -> cont 76#; - TokenSyntax -> cont 77#; - TokenHide -> cont 78#; - TokenLazy -> cont 79#; - TokenStatic -> cont 80#; - TokenRefl -> cont 81#; - TokenEmptyType -> cont 82#; - TokenUnitType -> cont 83#; - TokenInclude -> cont 84#; - TokenExport -> cont 85#; - TokenInline -> cont 86#; - TokenDo -> cont 87#; - TokenReturn -> cont 88#; - TokenIf -> cont 89#; - TokenThen -> cont 90#; - TokenElse -> cont 91#; - TokenLet -> cont 92#; - TokenIn -> cont 93#; - TokenProof -> cont 94#; - TokenTryProof -> cont 95#; - TokenIntro -> cont 96#; - TokenRefine -> cont 97#; - TokenGeneralise -> cont 98#; - TokenReflP -> cont 99#; - TokenRewrite -> cont 100#; - TokenRewriteAll -> cont 101#; - TokenCompute -> cont 102#; - TokenUnfold -> cont 103#; - TokenUndo -> cont 104#; - TokenInduction -> cont 105#; - TokenFill -> cont 106#; - TokenTrivial -> cont 107#; - TokenSimpleSearch -> cont 108#; - TokenMkTac -> cont 109#; - TokenBelieve -> cont 110#; - TokenUse -> cont 111#; - TokenDecide -> cont 112#; - TokenAbandon -> cont 113#; - TokenProofTerm -> cont 114#; - TokenQED -> cont 115#; - TokenLaTeX -> cont 116#; - TokenNoCG -> cont 117#; - TokenEval -> cont 118#; - TokenSpec -> cont 119#; - TokenFreeze -> cont 120#; - TokenThaw -> cont 121#; - TokenTransform -> cont 122#; - TokenCInclude -> cont 123#; - TokenCLib -> cont 124#; - _ -> happyError' tk - }) - -happyError_ tk = happyError' tk - -happyThen :: () => P a -> (a -> P b) -> P b -happyThen = (thenP) -happyReturn :: () => a -> P a -happyReturn = (returnP) -happyThen1 = happyThen -happyReturn1 :: () => a -> P a -happyReturn1 = happyReturn -happyError' :: () => (Token) -> P a -happyError' tk = (\token -> happyError) tk - -mkparse = happySomeParser where - happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut6 x)) - -mkparseTerm = happySomeParser where - happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (happyOut34 x)) - -mkparseTactic = happySomeParser where - happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (happyOut78 x)) - -happySeq = happyDontSeq - - -data ConParse = Full Id RawTerm - | Simple Id [RawTerm] - -parse :: String -> FilePath -> Result [Decl] -parse s fn = do ds <- mkparse s fn 1 [] - collectDecls ds - -processImports :: [Opt] -> [FilePath] -> Result [Decl] -> - IO ([Decl], [FilePath]) -processImports opts imped (Success ds) = pi imped [] ds - where pi imps decls ((PInclude fp):xs) - | fp `elem` imps = pi imps decls xs - | otherwise = do - f <- readLibFile defaultLibPath fp - when (Verbose `elem` opts) $ putStrLn ("Reading " ++ fp) - case parse f fp of - Success t -> pi (fp:imps) decls (t++xs) - Failure e f l -> - fail $ f ++ ":" ++ show l ++ ":" ++ e - pi imps decls ((Using t ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[Using t ds']) xs - pi imps decls ((Params t ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[Params t ds']) xs - pi imps decls ((DoUsing b r ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[DoUsing b r ds']) xs - pi imps decls ((Idiom b r ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[Idiom b r ds']) xs - pi imps decls ((Namespace n ds):xs) - = do (ds',imps') <- pi imps [] ds - pi imps' (decls++[Namespace n ds']) xs - pi imps decls (x:xs) = pi imps (decls++[x]) xs - pi imps decls [] = return (decls, imps) - -processImports _ imped (Failure e f l) - = fail $ show f ++ ":" ++ show l ++ ":" ++ show e - - -parseTerm :: String -> Result RawTerm -parseTerm s = mkparseTerm s "(input)" 0 [] - -parseTactic :: String -> Result ITactic -parseTactic s = mkparseTactic s "(tactic)" 0 [] - --- Make a constructor type, and make arguments lazy if it's codata - -mkCon :: Bool -> RawTerm -> ConParse -> (Id,RawTerm) -mkCon co _ (Full n t) = (n,if co then lazify t else t) -mkCon co ty (Simple n args) = (n, mkConTy args ty) - where mkConTy [] ty = ty - mkConTy (a:as) ty = let opts = if co then [Lazy] else [] in - RBind (MN "X" 0) (Pi Ex opts a) (mkConTy as ty) - --- Make sure all arguments are lazy - -lazify :: RawTerm -> RawTerm -lazify (RBind n (Pi p opts a) sc) - = RBind n (Pi p (nub (Lazy:opts)) a) (lazify sc) -lazify t = t - -mkDef file line (n, tms) = mkImpApp (RVar file line n Unknown) tms - where mkImpApp f [] = f - mkImpApp f ((tm,Just n):ts) = mkImpApp (RAppImp file line n f tm) ts - mkImpApp f ((tm, Nothing):ts) = mkImpApp (RApp file line f tm) ts - -doBind :: (RawTerm -> RBinder) -> [(Id,RawTerm)] -> RawTerm -> RawTerm -doBind b [] t = t -doBind b ((x,ty):ts) tm = RBind x (b ty) (doBind b ts tm) - -doLetBind :: [(Id,RawTerm,RawTerm)] -> RawTerm -> RawTerm -doLetBind [] t = t -doLetBind ((x,ty,val):ts) tm = RBind x (RLet val ty) (doLetBind ts tm) - -mkTyApp :: String -> Int -> Id -> RawTerm -> RawTerm -mkTyApp file line n ty = mkApp file line (RVar file line n Unknown) (getTyArgs ty) - where getTyArgs (RBind n _ t) = (RVar file line n Unknown):(getTyArgs t) - getTyArgs x = [] - -mkTyParams :: String -> Int -> [Id] -> RawTerm -mkTyParams f l [] = RConst f l TYPE -mkTyParams f l (x:xs) = RBind x (Pi Ex [] (RConst f l TYPE)) (mkTyParams f l xs) - -mkDatatype :: Bool -> String -> Int -> - Id -> Either RawTerm ((RawTerm, [(Id, RawTerm)]), [ConParse]) -> - [TyOpt] -> Datatype -mkDatatype co file line n (Right ((t, using), cons)) opts - = let opts' = if co then nub (Codata:opts) else opts in - Datatype n t (map (mkCon co (mkTyApp file line n t)) cons) using opts' file line -mkDatatype co file line n (Left t) opts - = Latatype n t file line - -bracket (RUserInfix f l _ op x y) = RUserInfix f l True op x y -bracket x = x - -pairDesugar :: String -> Int -> RawTerm -> [RawTerm] -> RawTerm -pairDesugar file line pair [x,y] = mkApp file line pair [x,y] -pairDesugar file line pair (x:y:xs) - = pairDesugar file line pair ((mkApp file line pair [x,y]):xs) - -sigDesugar :: String -> Int -> (Id, RawTerm) -> RawTerm -> RawTerm -sigDesugar file line (n, tm) sc - = mkApp file line (RVar file line (UN "Sigma") TypeCon) [tm, lam] - where lam = RBind n (Lam tm) sc - -mkConsList :: String -> Int -> [RawTerm] -> RawTerm -mkConsList f l [] = RVar f l (UN "Nil") Unknown -mkConsList f l (x:xs) = RApp f l (RApp f l (RVar f l (UN "Cons") Unknown) x) - (mkConsList f l xs) - -mkhidden (UN n) = MN (n++" is hidden") 0 -{-# 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" #-} - - -data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList - - - - - -{-# 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 0#, 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 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where !(new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where !(off) = indexShortOffAddr happyActOffsets st - !(off_i) = (off Happy_GHC_Exts.+# i) - check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) - then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) - else False - !(action) - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - -{-# LINE 130 "templates/GenericTemplate.hs" #-} - - -indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i - where - !i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - !high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - !low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - !off' = off Happy_GHC_Exts.*# 2# - - - - - -data HappyAddr = HappyA# Happy_GHC_Exts.Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - -{-# LINE 163 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let !(i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# 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@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - - !(off) = indexShortOffAddr happyGotoOffsets st1 - !(off_i) = (off Happy_GHC_Exts.+# nt) - !(new_state) = indexShortOffAddr happyTable off_i - - - - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where !(off) = indexShortOffAddr happyGotoOffsets st - !(off_i) = (off Happy_GHC_Exts.+# nt) - !(new_state) = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# 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 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- 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. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# 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/idris.cabal b/idris.cabal --- a/idris.cabal +++ b/idris.cabal @@ -1,72 +1,75 @@ Name: idris -Version: 0.1.7.1 +Version: 0.9.0 License: BSD3 License-file: LICENSE Author: Edwin Brady Maintainer: Edwin Brady Homepage: http://www.idris-lang.org/ -Stability: Alpha +Stability: Beta Category: Compilers/Interpreters, Dependent Types Synopsis: Dependently Typed Functional Programming Language -Description: Idris is an experimental language with full dependent types. +Description: Idris is a general purpose language with full dependent types. + It is compiled, with eager evaluation. Dependent types allow types to be predicated on values, meaning that some aspects of a program's behaviour can be specified precisely in the type. The language is closely - related to Epigram and Agda. There is a tutorial at . + related to Epigram and Agda. There is a tutorial at . + Features include: . - The aims of the project are: + * Full dependent types with dependent pattern matching + . + * where clauses, with rule, simple case expressions, + pattern matching let and lambda bindings . - * To provide a platform for realistic programming with dependent types. - By realistic, we mean the ability to interact with the outside world - and use primitive types and operations. This includes networking, - file handling, concurrency, etc. + * Type classes, monad comprehensions . - * To show that full dependent types do not mean we have to abandon - the functional style we have come to know and love with languages - like Haskell and OCaml. We aim to show that lightweight dependently typed - programming means allowing the programmer full access to values in types, - and letting the type checker do the hard work so you don't have to! + * do notation, idiom brackets, syntactic conveniences for lists, + tuples, dependent pairs . - The Darcs repository can be found at . -Homepage: http://www.cs.st-andrews.ac.uk/~eb/Idris/ + * Indentation significant syntax, extensible syntax + . + * Tactic based theorem proving (influenced by Coq) + . + * Cumulative universes + . + * Simple foreign function interface (to C) + . + * Hugs style interactive environment Cabal-Version: >= 1.6 -Build-type: Simple +Build-type: Custom -Data-files: Prelude.e *.idr -Data-dir: lib +Extra-source-files: lib/Makefile lib/*.idr lib/prelude/*.idr lib/network/*.idr + tutorial/examples/*.idr -Extra-source-files: CHANGELOG +source-repository head + type: git + location: git://github.com/edwinb/Idris-dev.git -Library - Exposed-modules: Idris.Parser, Idris.Lexer, Idris.Lib, - Idris.AbsSyntax, Idris.Context, Idris.Latex - Idris.Compiler, Idris.LambdaLift, Idris.PMComp, - Idris.MakeTerm, Idris.Prover, Idris.Fontlock, - Idris.ConTrans, Idris.SCTrans, Idris.RunIO, - Idris.SimpleCase, Idris.Serialise, Idris.PartialEval - Other-modules: Paths_idris - Build-depends: base>=4 && <5, containers, array, parsec, mtl, - readline, ivor>=0.1.14, directory, haskell98, - old-time, old-locale, binary, epic>=0.1.7, Cabal - - Extensions: MagicHash, UndecidableInstances, OverlappingInstances, PatternGuards - Executable idris - Main-is: Main.lhs - Other-modules: Idris.Parser, Idris.Lexer, Idris.Lib, - Idris.AbsSyntax, Idris.Context, - Idris.Compiler, Idris.LambdaLift, Idris.PMComp, - Idris.MakeTerm, Idris.Prover, Idris.Fontlock, - Idris.ConTrans, Idris.SCTrans, Idris.RunIO, - Idris.SimpleCase, Idris.Serialise, - Idris.PartialEval + Main-is: Main.hs + hs-source-dirs: src + Other-modules: Core.TT, Core.Evaluate, Core.Typecheck, + Core.ProofShell, Core.ProofState, Core.CoreParser, + Core.ShellParser, Core.Unify, Core.Elaborate, + Core.CaseTree, Core.Constraints, - Build-depends: base>=4 && <5, containers, array, parsec, mtl, - readline, ivor>=0.1.14, directory, haskell98, - old-time, old-locale, binary, epic>=0.1.6, Cabal + Idris.AbsSyntax, Idris.Parser, Idris.REPL, + Idris.REPLParser, Idris.ElabDecls, Idris.Error, + Idris.Delaborate, Idris.Primitives, Idris.Imports, + Idris.Compiler, Idris.Prover, Idris.ElabTerm, + Idris.Coverage, Idris.IBC, Idris.Unlit, + Idris.DataOpts, Idris.Transforms, + + Paths_idris + + Build-depends: base>=4 && <5, parsec, mtl, Cabal, haskeline, + containers, process, transformers, filepath, directory, + binary, bytestring, epic>=0.9.2 - Extensions: MagicHash, UndecidableInstances, OverlappingInstances, PatternGuards + Extensions: MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, TemplateHaskell ghc-prof-options: -auto-all + ghc-options: -rtsopts diff --git a/lib/Makefile b/lib/Makefile new file mode 100644 --- /dev/null +++ b/lib/Makefile @@ -0,0 +1,22 @@ + +check: .PHONY + $(BINDIR)/idris --noprelude --verbose --check checkall.idr + +recheck: clean check + +install: check + mkdir -p $(TARGET)/prelude + mkdir -p $(TARGET)/network + install *.ibc $(TARGET) + install prelude/*.ibc $(TARGET)/prelude + install network/*.ibc $(TARGET)/network + +clean: .PHONY + rm -f *.ibc + rm -f prelude/*.ibc + rm -f network/*.ibc + +linecount: .PHONY + wc -l *.idr network/*.idr prelude/*.idr + +.PHONY: diff --git a/lib/Prelude.e b/lib/Prelude.e deleted file mode 100644 --- a/lib/Prelude.e +++ /dev/null @@ -1,86 +0,0 @@ -%include "string.h" - --- IO - -%inline __epic_id (x:Any) -> Any = x - -%inline __epic_putStr (x:String) -> Unit = - foreign Unit "putStr" (x:String) - -__epic_readStr () -> String = - foreign String "readStr" () - -__epic_append (x:String, y:String) -> String = - foreign String "append" (x:String, y:String) - -__epic_strlen (x:String) -> Int = - foreign Int "strlen" (x:String) - -__epic_strhead (x:String) -> Int = - foreign Int "strHead" (x:String) - -__epic_strtail (x:String) -> String = - foreign String "strTail" (x:String) - -__epic_strcons (h:Int, x:String) -> String = - foreign String "strCons" (h:Int, x:String) - -__epic_streq (x:String, y:String) -> Data = - foreign Int "streq" (x:String, y:String) - -__epic_strrev (x:String) -> String = - foreign String "strrev" (x:String) - -__epic_substr (x:String, start:Int, len:Int) -> String = - foreign String "substr" (x:String, start: Int, len:Int) - -__epic_strFind (x:String, c:Int) -> Int = - foreign String "strFind" (x:String, c:Int) - -%inline __epic_chareq (x:Int, y:Int) -> Data = x==y - -%inline __epic_strlt (x:String, y:String) -> Data = - foreign Int "strlt" (x:String, y:String) - -__epic_newRef () -> Int = - foreign Int "newRef" () - -__epic_readRef (A:Any, r:Int) -> Any = - foreign Any "readRef" (r:Int) - -__epic_writeRef (A:Any, r:Int, v:Any) -> Unit = - foreign Unit "writeRef" (r:Int, v:Any) - -__epic_newLock (l:Int) -> Int = - foreign Int "newLock" (l:Int) - -__epic_doLock (l:Int) -> Unit = - foreign Unit "doLock" (l:Int) - -__epic_doUnlock (l:Int) -> Unit = - foreign Unit "doUnlock" (l:Int) - -__epic_fork (a:Any, f:Fun) -> Unit = - lazy foreign Unit "doFork" (f:Fun) - -__epic_within (a:Any, i:Int, f:Fun, fail:Fun) -> Unit = - lazy foreign Unit "doWithin" (i:Int, f:Fun, fail:Fun) - -%inline __epic_bool (x:Int) -> Data = - if (x==0) then (Con 1 ()) else (Con 0 ()) - -__epic_toInt (x:String) -> Int = - foreign Int "strToInt" (x:String) - -__epic_toString (x:Int) -> String = - foreign String "intToStr" (x:Int) - -__epic_floatToString (x:Float) -> String = - foreign String "floatToStr" (x:Float) - -__epic_stringToFloat (x:String) -> Float = - foreign Float "strToFloat" (x:String) - -__epic_native (x:Fun) -> Ptr = - foreign Ptr "getNative" (x:Fun) - diff --git a/lib/bool.idr b/lib/bool.idr deleted file mode 100644 --- a/lib/bool.idr +++ /dev/null @@ -1,35 +0,0 @@ -data Bool = True | False; - -not : Bool -> Bool; -not True = False; -not False = True; - -%transform not (not ?x) => ?x; - -if_then_else : Bool -> |(t:A) -> |(e:A) -> A; -if_then_else True t f = t; -if_then_else False t f = f; - -data so : Bool -> Set where oh : so True; - -infixl 4 &&,||; - -(||) : Bool -> Bool -> Bool; -(||) False x = x; -(||) True _ = True; - -(&&) : Bool -> Bool -> Bool; -(&&) True x = x; -(&&) False _ = False; - -or_commutes : (x:Bool) -> (y:Bool) -> ((x || y) = (y || x)); -or_commutes True False = refl _; -or_commutes True True = refl _; -or_commutes False False = refl _; -or_commutes False True = refl _; - -and_commutes : (x:Bool) -> (y:Bool) -> ((x && y) = (y && x)); -and_commutes True False = refl _; -and_commutes True True = refl _; -and_commutes False False = refl _; -and_commutes False True = refl _; diff --git a/lib/builtins.idr b/lib/builtins.idr --- a/lib/builtins.idr +++ b/lib/builtins.idr @@ -1,46 +1,239 @@ -include "bool.idr"; +%access public -data __Unit = II; -data __Empty = ; +data Exists : (a : Set) -> (P : a -> Set) -> Set where + Ex_intro : {P : a -> Set} -> (x : a) -> P x -> Exists a P -data Sigma : (A:Set)->(P:A->Set)->Set where - Exists : {P:A->Set} -> (a:A) -> P a -> Sigma A P; +getWitness : {P : a -> Set} -> Exists a P -> a +getWitness (a ** v) = a -getSigIdx : {P:a->Set} -> (s:Sigma a P) -> a; -getSigIdx (Exists a v) = a; +getProof : {P : a -> Set} -> (s : Exists a P) -> P (getWitness s) +getProof (a ** v) = v -getSigVal : {P:a->Set} -> (s:Sigma a P) -> P (getSigIdx s); -getSigVal (Exists a v) = v; +FalseElim : _|_ -> a -data Pair a b = mkPair a b; +-- For rewrite tactic +replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Set} -> x = y -> P x -> P y +replace refl prf = prf -id : a -> a; -id x = x; +sym : {l:a} -> {r:a} -> l = r -> r = l +sym refl = refl -rewrite : {A:B->Set} -> A m -> (m=n) -> A n; -rewrite t (refl m) = t; +lazy : a -> a +lazy x = x -- compiled specially --- This way is needed for Ivor's rewriting tactic +believe_me : a -> b -- compiled specially as id, use with care! +believe_me x = prim__believe_me _ _ x -__eq_repl : (A:Set)->(x:A) -> (y:A) -> (q:(x=y)) -> (P:(m:A)->Set) -> (p:P x) -> (P y); -__eq_repl A x x (refl _) P p = p; +namespace builtins { -__eq_sym : (A:Set) -> (a:A) -> (b:A) -> (p:(a=b)) -> (b=a); -__eq_sym A a a (refl _) = refl _; +id : a -> a +id x = x --- For proofs which should not be stored at run-time. Programs can --- construct objects of type Proof A, and manipulate them, --- but not inspect them. 'Proof' is treated as collapsible. +const : a -> b -> a +const x _ = x -data Proof : (A:Set) -> Set where - __mkProof : (a:A) -> Proof A; +fst : (s, t) -> s +fst (x, y) = x -prove : (a:A) -> Proof A; -prove x = __mkProof x; +snd : (a, b) -> b +snd (x, y) = y --- This is the only function allowed to manipulate proofs. --- It'd be easier if we could hide '__mkProof'! +infixl 9 . -proof_bind : Proof A -> (A -> Proof B) -> Proof B; -proof_bind (__mkProof a) p = p a; +(.) : (b -> c) -> (a -> b) -> a -> c +(.) f g x = f (g x) + +flip : (a -> b -> c) -> b -> a -> c +flip f x y = f y x + +infixr 1 $ + +($) : (a -> b) -> a -> b +f $ a = f a + +data Bool = False | True + +boolElim : (x:Bool) -> |(t : a) -> |(f : a) -> a +boolElim True t e = t +boolElim False t e = e + +data so : Bool -> Set where oh : so True + +syntax if [test] then [t] else [e] = boolElim test t e +syntax [test] "?" [t] ":" [e] = if test then t else e + +infixl 4 &&, || + +(||) : Bool -> Bool -> Bool +(||) False x = x +(||) True _ = True + +(&&) : Bool -> Bool -> Bool +(&&) True x = x +(&&) False _ = False + +not : Bool -> Bool +not True = False +not False = True + +infixl 5 ==, /=, ==. +infixl 6 <, <=, >, >=, <., <=., >., >=. +infixl 7 <<, >> +infixl 8 +,-,++,+.,-. +infixl 9 *,/,*.,/. + +--- Numeric operators + +intToBool : Int -> Bool +intToBool 0 = False +intToBool x = True + +boolOp : (a -> a -> Int) -> a -> a -> Bool +boolOp op x y = intToBool (op x y) + +class Eq a where + (==) : a -> a -> Bool + (/=) : a -> a -> Bool + + x /= y = not (x == y) + x == y = not (x /= y) + +instance Eq Int where + (==) = boolOp prim__eqInt + +instance Eq Integer where + (==) = boolOp prim__eqBigInt + +instance Eq Float where + (==) = boolOp prim__eqFloat + +instance Eq Char where + (==) = boolOp prim__eqChar + +instance Eq String where + (==) = boolOp prim__eqString + +data Ordering = LT | EQ | GT + +class Eq a => Ord a where + compare : a -> a -> Ordering + + (<) : a -> a -> Bool + (<) x y with (compare x y) + (<) x y | LT = True + (<) x y | _ = False + + (>) : a -> a -> Bool + (>) x y with (compare x y) + (>) x y | GT = True + (>) x y | _ = False + + (<=) : a -> a -> Bool + (<=) x y = x < y || x == y + + (>=) : a -> a -> Bool + (>=) x y = x > y || x == y + + max : a -> a -> a + max x y = if (x > y) then x else y + + min : a -> a -> a + min x y = if (x < y) then x else y + + + +instance Ord Int where + compare x y = if (x == y) then EQ else + if (boolOp prim__ltInt x y) then LT else + GT + + +instance Ord Integer where + compare x y = if (x == y) then EQ else + if (boolOp prim__ltBigInt x y) then LT else + GT + + +instance Ord Float where + compare x y = if (x == y) then EQ else + if (boolOp prim__ltFloat x y) then LT else + GT + + +instance Ord Char where + compare x y = if (x == y) then EQ else + if (boolOp prim__ltChar x y) then LT else + GT + + +instance Ord String where + compare x y = if (x == y) then EQ else + if (boolOp prim__ltString x y) then LT else + GT + + +class (Eq a, Ord a) => Num a where + (+) : a -> a -> a + (-) : a -> a -> a + (*) : a -> a -> a + + abs : a -> a + abs x = if (x < 0) then (-x) else x + + fromInteger : Int -> a + + + +instance Num Int where + (+) = prim__addInt + (-) = prim__subInt + (*) = prim__mulInt + + fromInteger = id + + +instance Num Integer where + (+) = prim__addBigInt + (-) = prim__subBigInt + (*) = prim__mulBigInt + + fromInteger = prim__intToBigInt + + +instance Num Float where + (+) = prim__addFloat + (-) = prim__subFloat + (*) = prim__mulFloat + + fromInteger = prim__intToFloat + + +div : Int -> Int -> Int +div = prim__divInt + + +(/) : Float -> Float -> Float +(/) = prim__divFloat + +--- string operators + +(++) : String -> String -> String +(++) = prim__concat + +strHead : String -> Char +strHead = prim__strHead + +strTail : String -> String +strTail = prim__strTail + +strCons : Char -> String -> String +strCons = prim__strCons + +strIndex : String -> Int -> Char +strIndex = prim__strIndex + +rev : String -> String +rev = prim__strRev + +} diff --git a/lib/checkall.idr b/lib/checkall.idr new file mode 100644 --- /dev/null +++ b/lib/checkall.idr @@ -0,0 +1,24 @@ +module checkall + +-- This file just exists to typecheck all the prelude modules +-- Add imports here + +import builtins +import prelude +import io +import system + +import prelude.cast +import prelude.nat +import prelude.fin +import prelude.list +import prelude.maybe +import prelude.monad +import prelude.applicative +import prelude.either +import prelude.vect +import prelude.strings +import prelude.char + +import network.cgi + diff --git a/lib/either.idr b/lib/either.idr deleted file mode 100644 --- a/lib/either.idr +++ /dev/null @@ -1,9 +0,0 @@ -data Either A B = Left A | Right B; - -choose : (x:Bool) -> Either (so (not x)) (so x); -choose False = Left oh; -choose True = Right oh; - -either : Either a b -> (a -> c) -> (b -> c) -> c; -either (Left a) fa fb = fa a; -either (Right b) fa fb = fb b; diff --git a/lib/equalities.idr b/lib/equalities.idr deleted file mode 100644 --- a/lib/equalities.idr +++ /dev/null @@ -1,39 +0,0 @@ -include "maybe.idr"; -include "vect.idr"; - -data EqNat : Nat -> Nat -> Set where - eqO : EqNat O O - | eqS : EqNat x y -> EqNat (S x) (S y); - -eqNat' : (x:Nat) -> (y:Nat) -> Maybe (EqNat x y); -eqNat' O O = Just eqO; -eqNat' (S x) (S y) with eqNat' x y { - eqNat' (S x) (S x) | Just p = Just (eqS p); - eqNat' (S x) (S y) | Nothing = Nothing; -} -eqNat' _ _ = Nothing; - -eqNat : Nat -> Nat -> Bool; -eqNat x y with eqNat' x y { - eqNat x x | Just _ = True; - eqNat x y | Nothing = False; -} - -data EqFin : Fin n -> Fin n -> Set where - eqfO : {k:Nat} -> EqFin {n=S k} fO fO - | eqfS : {x:Fin n} -> {y:Fin n} -> EqFin x y -> EqFin (fS x) (fS y); - -eqFin' : (x:Fin n) -> (y:Fin n) -> Maybe (EqFin x y); -eqFin' fO fO = Just eqfO; -eqFin' (fS x) (fS y) with eqFin' x y { - eqFin' (fS x) (fS x) | Just p = Just (eqfS p); - eqFin' (fS x) (fS y) | Nothing = Nothing; -} -eqFin' _ _ = Nothing; - -eqFin : Fin n -> Fin n -> Bool; -eqFin x y with eqFin' x y { - eqFin x x | Just _ = True; - eqFin x y | Nothing = False; -} - diff --git a/lib/io.idr b/lib/io.idr --- a/lib/io.idr +++ b/lib/io.idr @@ -1,272 +1,45 @@ -include "list.idr"; +import prelude.list --- FAny is to allow C functions to build up Idris data --- types. Obviously this needs care... +%access public -data FType = FUnit | FInt | FStr | FPtr | FFloat | FAny Set - | FIntP (Int -> Bool); +abstract data IO a = prim__IO a -i_ftype : FType -> Set; -i_ftype FInt = Int; -i_ftype FStr = String; -i_ftype FPtr = Ptr; -i_ftype FFloat = Float; -i_ftype FUnit = (); -i_ftype (FAny ty) = ty; -i_ftype (FIntP p) = (x : Int ** so (p x)); +abstract +io_bind : IO a -> (a -> IO b) -> IO b +io_bind (prim__IO v) k = k v -data ForeignFun = FFun String (List FType) FType; +abstract +io_return : a -> IO a +io_return x = prim__IO x -f_retType : ForeignFun -> FType; -f_retType (FFun nm args ret) = ret; +-- This may seem pointless, but we can use it to force an +-- evaluation of main that Epic wouldn't otherwise do... -f_args : ForeignFun -> (List FType); -f_args (FFun nm args ret) = args; +run__IO : IO () -> IO () +run__IO v = io_bind v (\v' => io_return v') -f_name : ForeignFun -> String; -f_name (FFun nm args ret) = nm; +data FTy = FInt | FFloat | FChar | FString | FPtr | FUnit -data FArgList : (List FType) -> Set where - fNil : FArgList Nil - | fCons : {x:FType} -> (fx:i_ftype x) -> (fxs:FArgList xs) -> - (FArgList (Cons x xs)); +interpFTy : FTy -> Set +interpFTy FInt = Int +interpFTy FFloat = Float +interpFTy FChar = Char +interpFTy FString = String +interpFTy FPtr = Ptr +interpFTy FUnit = () -fapp : {xs,ys:List FType} -> - (FArgList xs) -> (FArgList ys) -> (FArgList (app xs ys)); -fapp fNil fxs = fxs; -fapp (fCons fx fxs) fys = fCons fx (fapp fxs fys); +ForeignTy : (xs:List FTy) -> (t:FTy) -> Set +ForeignTy xs t = mkForeign' (rev xs) (IO (interpFTy t)) where + mkForeign' : List FTy -> Set -> Set + mkForeign' Nil ty = ty + mkForeign' (s :: ss) ty = mkForeign' ss (interpFTy s -> ty) -namespace IO { - data IO : Set -> Set; - - data Command : Set where - PutStr : String -> Command - | GetStr : Command - | Fork : {A:Set} -> A -> Command - | NewLock : Int -> Command - | DoLock : Lock -> Command - | DoUnlock : Lock -> Command - | NewRef : Command - | ReadRef : Set -> Int -> Command - | WriteRef : {A:Set} -> Int -> A -> Command - | While : (IO Bool) -> (IO ()) -> Command - | WhileAcc : {A:Set} -> (IO Bool) -> A -> (A -> IO A) -> Command - | Within : Int -> (IO A) -> (IO A) -> Command - | IOLift : {A:Set} -> (IO A) -> Command - | Foreign : (f:ForeignFun) -> - (args:FArgList (f_args f)) -> Command; +data Foreign : Set -> Set where + FFun : String -> (xs:List FTy) -> (t:FTy) -> + Foreign (ForeignTy xs t) - Response : Command -> Set; - Response (PutStr s) = (); - Response GetStr = String; - Response (Fork proc) = (); - Response (NewLock i) = Lock; - Response (DoLock l) = (); - Response (DoUnlock l) = (); - Response NewRef = Int; - Response (ReadRef A i) = A; - Response (WriteRef i val) = (); - Response (While _ body) = (); - Response (WhileAcc {A} _ acc body) = A; - Response (Within {A} time body failure) = A; - Response (IOLift {A} f) = A; - Response (Foreign t args) = i_ftype (f_retType t); +mkForeign : Foreign x -> x +-- mkForeign compiled as primitive - data IO : Set -> Set where - IOReturn : A -> (IO A) - | IODo : (c:Command) -> ((Response c) -> (IO A)) -> (IO A); - - data IORef A = MkIORef Int; - - bind : (IO a) -> (a -> (IO b)) -> (IO b); - bind (IOReturn a) k = k a; - -- bind (IODo (IOLift {A} c) p) k = bind (bind c p) k; - bind (IODo c p) k = IODo c (\y => (bind (p y) k)); - -- bind (IOError str) k = IOError str; - - ret : a -> IO a; - ret x = IOReturn x; -} - -kbind : (IO a) -> (a -> b) -> (IO b); -kbind (IOReturn a) k = IOReturn (k a); -kbind (IODo c p) k = IODo c (\x => (kbind (p x) k)); - -while : |(test:IO Bool) -> |(body: IO ()) -> IO (); -while t body = IODo (While t body) (\a => (IOReturn II)); - -while_accTR : Bool -> - |(test:IO Bool) -> acc -> |(body: acc -> IO acc) -> IO acc; - -while_acc : |(test:IO Bool) -> acc -> |(body: acc -> IO acc) -> IO acc; -{- -while_acc test acc body = do { test' <- test; - while_accTR test' test acc body; }; - -while_accTR True test acc body = do { acc' <- body acc; - test' <- test; - while_accTR test' test acc' body; }; -while_accTR False test acc body = return acc; --} -while_acc test acc body = IODo (WhileAcc test acc body) (\a => (IOReturn a)); - -{- -ioReturn : a -> (IO a); -ioReturn x = IOReturn x; --} - -apply : IO (a -> b) -> IO a -> IO b; -apply {a} {b} fn arg = do { f : (a->b) <- fn; -- grr - x <- arg; - return (f x); }; - -data IOException = IOExcept String; - -data IOe : Set -> Set where - IOK : (IO A) -> (IOe A) - | IOError : String -> (IOe A); - -{- -catch : (IOe A) -> (IOException -> (IO A)) -> (IO A); -catch (IOK action) = action; -catch (IOError str) handler = handler (IOExcept str); --} - --- No code for this - only works in compiled code, certainly shouldn't --- be evaluted in pure code! -unsafePerformIO : (IO A) -> A; - --- get the rts representation of a value -unsafeNative : A -> Ptr; - -putStr : String -> (IO ()); -putStr str = IODo (PutStr str) (\a => (IOReturn a)); - -getStr : IO String; -getStr = IODo GetStr (\b => (IOReturn b)); - -getInt : IO Int; -getInt = do { inp <- getStr; - let val = __toInt inp; - return val; }; - -putStrLn : String -> (IO ()); -putStrLn str = do { putStr str; - putStr "\n"; }; - -fork : |(proc:IO ()) -> (IO ()); -fork proc = IODo (Fork proc) (\a => (IOReturn a)); - -newLock : Int -> (IO Lock); -newLock i = IODo (NewLock i) (\l => (IOReturn l)); - -lock : Lock -> (IO ()); -lock l = IODo (DoLock l) (\a => (IOReturn a)); - -unlock : Lock -> (IO ()); -unlock l = IODo (DoUnlock l) (\a => (IOReturn a)); - --- Perform an action within "time" milliseconds, execute failure --- routine if it doesn't complete - -within : Int -> |(action : IO a) -> |(failure : IO a) -> IO a; -within time act fail = IODo (Within time act fail) (\a => (IOReturn a)); - -newIORefPrim : IO Int; -newIORefPrim = IODo (NewRef) (\i => (IOReturn i)); - -readIORefPrim : Int -> (IO A); -readIORefPrim {A} i = IODo (ReadRef A i) (\a => (IOReturn a)); - -writeIORefPrim : Int -> A -> (IO ()); -writeIORefPrim {A} i val = IODo (WriteRef {A} i val) (\a => (IOReturn a)); - -newIORef : A -> (IO (IORef A)); -newIORef val = do { i <- newIORefPrim; - writeIORefPrim i val; - return (MkIORef i); - }; - -readIORef : (IORef A) -> (IO A); -readIORef (MkIORef i) = readIORefPrim i; - -writeIORef : (IORef A) -> A -> (IO ()); -writeIORef (MkIORef i) val = writeIORefPrim i val; - -mkFType' : (List FType) -> FType -> Set ; [%nocg] - -mkFType' Nil rt = IO (i_ftype rt); -mkFType' (Cons t ts) rt = (i_ftype t) -> (mkFType' ts rt); - -mkFType : ForeignFun -> Set ; [%nocg] -mkFType (FFun fn args rt) = mkFType' args rt; - -mkFDef : String -> (ts:List FType) -> (xs:List FType) -> (FArgList xs) -> - (rt:FType) -> (mkFType' ts rt) ; [%nocg] -mkFDef nm Nil accA fs rt - = IODo (Foreign (FFun nm accA rt) fs) - (\a => (IOReturn a)); -mkFDef nm (Cons t ts) accA fs rt - = \x:i_ftype t => mkFDef nm ts (app accA (Cons t Nil)) - (fapp fs (fCons x fNil)) rt; - -mkForeign : (f:ForeignFun) -> (mkFType f) ; [%nocg] -mkForeign (FFun fn args rt) = mkFDef fn args Nil fNil rt; - -_isNull = mkForeign (FFun "isNull" (Cons FPtr Nil) FInt); [%eval] - -isNull : Ptr -> Bool; -isNull ptr = if_then_else ((unsafePerformIO (_isNull ptr))==0) False True; - -data File = FHandle Ptr; - -_fopen - = mkForeign (FFun "fileOpen" (Cons FStr (Cons FStr Nil)) FPtr); [%eval] -_fclose - = mkForeign (FFun "fileClose" (Cons FPtr Nil) FUnit); [%eval] -_fread - = mkForeign (FFun "freadStr" (Cons FPtr Nil) (FAny String)); [%eval] -_fwrite - = mkForeign (FFun "fputStr" (Cons FPtr (Cons FStr Nil)) FUnit); [%eval] -_feof - = mkForeign (FFun "feof" (Cons FPtr Nil) FInt); [%eval] - -gc_details - = mkForeign (FFun "epicMemInfo" Nil FUnit); [%eval] - -gc_collect - = mkForeign (FFun "epicGC" Nil FUnit); [%eval] - -validFile : File -> Bool; -validFile (FHandle p) = not (isNull p); - -fopen : String -> String -> IO File; -fopen str mode = do { ho <- _fopen str mode; - return (FHandle ho); }; - -fclose : File -> IO (); -fclose (FHandle h) = _fclose h; - -fread : File -> IO String; -fread (FHandle hn) = _fread hn; - -fwrite : File -> String -> IO (); -fwrite (FHandle h) str = _fwrite h str; - -feof : File -> IO Bool; -feof (FHandle h) = do { eof <- _feof h; - return (not (eof==0)); }; - -sequence : (List (IO a)) -> (IO (List a)); -sequence Nil = return Nil; -sequence (Cons x xs) = do { a <- x; - as <- sequence xs; - return (Cons a as); }; - -sleep = mkForeign (FFun "sleep" (Cons FInt Nil) FUnit); [%eval] - --- Return time in microseconds since some unspecified starting point - -utime = mkForeign (FFun "do_utime" Nil FInt); [%eval] diff --git a/lib/list.idr b/lib/list.idr deleted file mode 100644 --- a/lib/list.idr +++ /dev/null @@ -1,79 +0,0 @@ -data List a = Nil | Cons a (List a); - -map : (a->b) -> (List a) -> (List b); -map f Nil = Nil; -map f (Cons x xs) = Cons (f x) (map f xs); - -consp : Bool -> a -> (List a) -> (List a); -consp True x xs = Cons x xs; -consp False x xs = xs; - -filter : (a->Bool) -> (List a) -> (List a); -filter p Nil = Nil; -filter p (Cons x xs) = consp (p x) x (filter p xs); - -maybeCons : (Maybe a) -> (List a) -> (List a); -maybeCons Nothing xs = xs; -maybeCons (Just a) xs = (Cons a xs); - -mapMaybe : (a->(Maybe b)) -> (List a) -> (List b); -mapMaybe f Nil = Nil; -mapMaybe f (Cons x xs) = maybeCons (f x) (mapMaybe f xs); - -app : (List a) -> (List a) -> (List a); -app Nil xs = xs; -app (Cons x xs) ys = Cons x (app xs ys); - -foldl : (a -> b -> a) -> a -> (List b) -> a; -foldl f z Nil = z; -foldl f z (Cons x xs) = foldl f (f z x) xs; - -foldr : (a -> b -> b) -> b -> (List a) -> b; -foldr f z Nil = z; -foldr f z (Cons x xs) = f x (foldr f z xs); - -rev : (List a) -> (List a); -rev xs = foldl (flip Cons) Nil xs; - -eq_resp_Cons : {xs,ys:List A} -> (xs=ys) -> ((Cons x xs) = (Cons x ys)); -eq_resp_Cons {A} {x} (refl xs) = refl _; - -elem : (a->a->Bool) -> a -> (List a) -> Bool; -elem q x Nil = False; -elem q x (Cons y ys) = if_then_else (q x y) True (elem q x ys); - -app_assoc : (xs:List a) -> (ys:List a) -> (zs:List a) -> - (app xs (app ys zs) = app (app xs ys) zs); - -app_assoc Nil ys zs = refl _; -app_assoc (Cons x xs) ys zs = let rec = app_assoc xs ys zs in - ?app_assocCons; -app_assocCons proof { - %intro; - %rewrite rec; - %refl; - %qed; -}; - -app_Nil : (xs:List a) -> (app xs Nil = xs); -app_Nil Nil = refl _; -app_Nil (Cons x xs) = ?appNil_Cons; -appNil_Cons proof { - %intro a; - %intro; - %rewrite <- app_Nil xs; - %refl; - %qed; -}; - -span' : (a -> Bool) -> List a -> List a -> (List a & List a); -span' p Nil acc = (rev acc, Nil); -span' p (Cons x xs) acc = if (p x) then (span' p xs (Cons x acc)) - else (rev acc, Cons x xs); - -span : (a -> Bool) -> List a -> (List a & List a); -span p xs = span' p xs Nil; - -length : List a -> Int; -length Nil = 0; -length (Cons x xs) = 1 + length xs; diff --git a/lib/maybe.idr b/lib/maybe.idr deleted file mode 100644 --- a/lib/maybe.idr +++ /dev/null @@ -1,13 +0,0 @@ -data Maybe A = Just A | Nothing; - -mMap : (f:A->B) -> (Maybe A) -> (Maybe B); -mMap f Nothing = Nothing; -mMap f (Just a) = Just (f a); - -maybe : (x:Maybe a) -> |(default:b) -> (a->b) -> b; -maybe Nothing def f = def; -maybe (Just a) def f = f a; - -maybeBind : Maybe a -> (a -> Maybe b) -> Maybe b; -maybeBind Nothing mf = Nothing; -maybeBind (Just x) mf = mf x; diff --git a/lib/nat.idr b/lib/nat.idr deleted file mode 100644 --- a/lib/nat.idr +++ /dev/null @@ -1,147 +0,0 @@ -data Nat = O | S Nat; - -plus : Nat -> Nat -> Nat; -plus O y = y; -plus (S k) y = S (plus k y); - -mult : Nat -> Nat -> Nat; -mult O y = O; -mult (S k) y = plus y (mult k y); - -eq_resp_S : (m=n) -> ((S m) = (S n)); -eq_resp_S (refl n) = refl (S n); - -power : Nat -> Nat -> Nat; -power n O = S O; -power n (S k) = mult n (power n k); - -------- Int/String conversions ------- - -intToNat : Int -> Nat; - -in' : Bool -> Nat -> Int -> Nat; -in' True n i = n; -in' False n i = S (intToNat (i-1)); - -intToNat n = in' (n<=0) O n; - -natToInt : Nat -> Int; -natToInt O = 0; -natToInt (S k) = 1+(natToInt k); - ------------ plus theorems ----------- - -plus_nO : (n:Nat) -> ((plus n O) = n); -plus_nO O = (refl O); -plus_nO (S n) = eq_resp_S (plus_nO n); - -plus_nSm : (m:Nat, n:Nat) -> ((plus n (S m)) = (S (plus n m))); -plus_nSm m O = refl (S m); -plus_nSm m (S k) = eq_resp_S (plus_nSm m k); - -plus_comm : (x:Nat, y:Nat) -> (plus x y = plus y x); -plus_comm proof { - %intro; %induction x; - %rewrite <- plus_nO y; - %refl; - %intro n,ih; - %rewrite <- (plus_nSm n y); - %rewrite ih; - %refl; - %qed; -}; - -plus_assoc : (m:Nat, n:Nat, p:Nat) -> (plus m (plus n p) = plus (plus m n) p); -plus_assoc proof { - %intro; - %induction m; - %compute; - %refl; - %intro k; - %intro ih; - %compute; - %rewrite <- ih; - %refl; - %qed; -}; - ------------ mult theorems ----------- - -mult_nO : (n:Nat) -> ((mult n O) = O); -mult_nO O = refl _; -mult_nO (S k) = mult_nO k; - -mult_nSm : (n:Nat, m:Nat) -> ((mult n (S m)) = (plus n (mult n m))); -mult_nSm proof { - %intro; - %induction n; - %refl; - %intro k,ih; - %compute; - %refine eq_resp_S; - %rewrite <- ih; - %generalise mult k m; - %intro x; - %rewrite <- plus_comm m x; - %rewrite <- plus_assoc k x m; - %rewrite <- plus_comm m (plus k x); - %refl; - %qed; -}; - -mult_comm : (x:Nat, y:Nat) -> ((mult x y) = (mult y x)); -mult_comm proof { - %intro; - %induction x; - %rewrite <- mult_nO y; - %refl; - %intro k,ih; - %compute; - %rewrite <- mult_nSm y k; - %rewrite <- ih; - %refl; - %qed; -}; - -mult_distrib : (m:Nat, n:Nat, p:Nat) -> - (plus (mult m p) (mult n p) = mult (plus m n) p); -mult_distrib proof { - %intro; - %induction m; - %refl; - %intro k,ih; - %compute; - %rewrite ih; - %rewrite plus_assoc p (mult k p) (mult n p); - %refl; - %qed; -}; - ----- Comparing Nats - -data Compare : Nat -> Nat -> Set where - cmpLT : (y:Nat) -> (Compare x (plus x (S y))) - | cmpEQ : Compare x x - | cmpGT : (x:Nat) -> (Compare (plus y (S x)) y); - -compareAux : (Compare n m) -> (Compare (S n) (S m)); -compareAux (cmpLT y) = cmpLT _; -compareAux cmpEQ = cmpEQ; -compareAux (cmpGT x) = cmpGT _; - -compare : (n:Nat) -> (m:Nat) -> (Compare n m); -compare O O = cmpEQ; -compare (S n) O = cmpGT _; -compare O (S m) = cmpLT _; -compare (S n) (S m) = compareAux (compare n m); - -ltNat : Nat -> Nat -> Bool; -ltNat O (S x) = True; -ltNat (S x) O = False; -ltNat O O = False; -ltNat (S x) (S y) = ltNat x y; - -max : Nat -> Nat -> Nat; -max O n = n; -max (S n) O = S n; -max (S n) (S m) = S (max n m); diff --git a/lib/network/cgi.idr b/lib/network/cgi.idr new file mode 100644 --- /dev/null +++ b/lib/network/cgi.idr @@ -0,0 +1,144 @@ +module network.cgi + +import system + +public +Vars : Set +Vars = List (String, String) + +data CGIInfo = CGISt Vars -- GET + Vars -- POST + Vars -- Cookies + String -- User agent + String -- headers + String -- output + +get_GET : CGIInfo -> Vars +get_GET (CGISt g _ _ _ _ _) = g + +get_POST : CGIInfo -> Vars +get_POST (CGISt _ p _ _ _ _) = p + +get_Cookies : CGIInfo -> Vars +get_Cookies (CGISt _ _ c _ _ _) = c + +get_UAgent : CGIInfo -> String +get_UAgent (CGISt _ _ _ a _ _) = a + +get_Headers : CGIInfo -> String +get_Headers (CGISt _ _ _ _ h _) = h + +get_Output : CGIInfo -> String +get_Output (CGISt _ _ _ _ _ o) = o + +add_Headers : String -> CGIInfo -> CGIInfo +add_Headers str (CGISt g p c a h o) = CGISt g p c a (h ++ str) o + +add_Output : String -> CGIInfo -> CGIInfo +add_Output str (CGISt g p c a h o) = CGISt g p c a h (o ++ str) + +abstract +data CGI : Set -> Set where + MkCGI : (CGIInfo -> IO (a, CGIInfo)) -> CGI a + +getAction : CGI a -> CGIInfo -> IO (a, CGIInfo) +getAction (MkCGI act) = act + +instance Monad CGI where { + (>>=) (MkCGI f) k = MkCGI (\s => do v <- f s + getAction (k (fst v)) (snd v)) + + return v = MkCGI (\s => return (v, s)) +} + +setInfo : CGIInfo -> CGI () +setInfo i = MkCGI (\s => return ((), i)) + +getInfo : CGI CGIInfo +getInfo = MkCGI (\s => return (s, s)) + +abstract +lift : IO a -> CGI a +lift op = MkCGI (\st => do { x <- op + return (x, st) } ) + +abstract +output : String -> CGI () +output s = do i <- getInfo + setInfo (add_Output s i) + +abstract +queryVars : CGI Vars +queryVars = do i <- getInfo + return (get_GET i) + +abstract +postVars : CGI Vars +postVars = do i <- getInfo + return (get_POST i) + +abstract +cookieVars : CGI Vars +cookieVars = do i <- getInfo + return (get_Cookies i) + +abstract +queryVar : String -> CGI (Maybe String) +queryVar x = do vs <- queryVars + return (lookup x vs) + +getOutput : CGI String +getOutput = do i <- getInfo + return (get_Output i) + +getHeaders : CGI String +getHeaders = do i <- getInfo + return (get_Headers i) + +abstract +flushHeaders : CGI () +flushHeaders = do o <- getHeaders + lift (putStrLn o) + +abstract +flush : CGI () +flush = do o <- getOutput + lift (putStr o) + +getVars : List Char -> String -> List (String, String) +getVars seps query = mapMaybe readVar (split (\x => elem x seps) query) + where + readVar : String -> Maybe (String, String) + readVar xs with (split (\x => x == '=') xs) + | [k, v] = Just (trim k, trim v) + | _ = Nothing + +getContent : Int -> IO String +getContent x = getC x "" where + getC : Int -> String -> IO String + getC 0 acc = return $ rev acc + getC n acc = do x <- getChar + getC (n-1) (strCons x acc) + +abstract +runCGI : CGI a -> IO a +runCGI prog = do + clen_in <- getEnv "CONTENT_LENGTH" + let clen = prim__strToInt clen_in + content <- getContent clen + query <- getEnv "QUERY_STRING" + cookie <- getEnv "HTTP_COOKIE" + agent <- getEnv "HTTP_USER_AGENT" + + let get_vars = getVars ['&',';'] query + let post_vars = getVars ['&'] content + let cookies = getVars [';'] cookie + + p <- getAction prog (CGISt get_vars post_vars cookies agent + "Content-type: text/html\n" + "") + putStrLn (get_Headers (snd p)) + putStr (get_Output (snd p)) + return (fst p) + + diff --git a/lib/perm.idr b/lib/perm.idr deleted file mode 100644 --- a/lib/perm.idr +++ /dev/null @@ -1,139 +0,0 @@ -include "vect.idr"; - --- Yes, it's a DSL! One which gives a sequence of operations for converting a --- list into its permutation. - -using (x:A, xs:List A, xs':List A, xs'':List A, - ys:List A, ys':List A, - zs:List A) -{ - data Perm : (List A) -> (List A) -> Set where - pnil : {A:Set} -> (Perm {A} Nil Nil) - | pskip : (Perm xs xs') -> (Perm (Cons x xs) (Cons x xs')) - | pswap : (Perm (Cons x (Cons y xs)) (Cons y (Cons x xs))) - | ptrans : (Perm xs xs') -> (Perm xs' xs'') -> (Perm xs xs''); - - perm_id: Perm xs xs; - perm_id {xs=Nil} = pnil; - perm_id {xs=Cons x xs} = pskip perm_id; - - perm_sym : Perm xs xs' -> Perm xs' xs; - perm_sym pnil = pnil; - perm_sym (pskip p) = pskip (perm_sym p); - perm_sym pswap = pswap; - perm_sym (ptrans p q) = ptrans (perm_sym q) (perm_sym p); - - perm_refl : Perm xs xs; - perm_refl {xs=Nil} = pnil; - perm_refl {xs=Cons x xs} = pskip perm_refl; - - perm_app_head : (xs:List A) -> - Perm xs' ys' -> Perm (app xs xs') (app xs ys'); - perm_app_head Nil p = p; - perm_app_head (Cons x xs) p = pskip (perm_app_head xs p); - - perm_add_cons : Perm (Cons x xs) (Cons x ys) -> Perm xs ys; - perm_add_cons (pskip p) = p; - perm_add_cons pswap = pskip perm_id; - - perm_app : Perm xs ys -> Perm xs' ys' -> - Perm (app xs xs') (app ys ys'); - perm_app {xs=Nil} {ys=Nil} p p' = p'; - perm_app {xs=Cons x xs} {ys=Cons y ys} {xs'} {ys'} (ptrans p1 p2) p' = - let r1 = perm_app p1 p' in - let r2 = perm_app p2 p' in ?papp_cons; - - perm_rewrite : Perm xs xs' -> Perm xs ys -> Perm xs' ys; - perm_rewrite p1 p2 = ptrans (perm_sym p1) p2; - - perm_rewrite_cons : Perm (Cons x xs) xs' -> Perm xs ys -> - Perm (Cons x ys) xs'; - perm_rewrite_cons (pskip p1) p2 = pskip (ptrans (perm_sym p2) p1); - perm_rewrite_cons pswap p = ptrans (pskip (perm_sym p)) pswap; - perm_rewrite_cons (ptrans p1 p2) p3 = ptrans (perm_rewrite_cons p1 p3) p2; - - perm_rewrite_app : Perm (app xs ys) xs' -> Perm ys zs -> - Perm (app xs zs) xs'; - perm_rewrite_app {xs=Nil} p1 p2 = perm_rewrite p2 p1; - perm_rewrite_app {xs=Cons x xs} p1 p2 - = perm_rewrite_cons p1 (perm_app perm_id p2); - - perm_swapr : Perm xs (Cons x (Cons y ys)) -> - Perm xs (Cons y (Cons x ys)); - perm_swapr {xs=Cons a (Cons b xs)} p = ptrans p pswap; - - perm_swapl : Perm (Cons x (Cons y ys)) xs -> - Perm (Cons y (Cons x ys)) xs; - perm_swapl {xs=Cons a (Cons b xs)} p = ptrans pswap p; - - perm_move_cons : Perm xs (app ys (Cons x zs)) -> - Perm xs (Cons x (app ys zs)); - perm_move_cons {ys=Nil} p = p; - perm_move_cons {ys=Cons y ys} p - = perm_swapr (perm_sym - (perm_rewrite_cons (perm_sym p) (perm_move_cons perm_id))); - - perm_cons_move : Perm xs (Cons x (app ys zs)) -> - Perm xs (app ys (Cons x zs)); - - perm_cons_move {ys=Nil} p = p; - perm_cons_move {ys=Cons y ys} p - = perm_sym (perm_rewrite_cons - (perm_swapl (perm_sym p)) (perm_cons_move perm_id)); - - -- This is by induction on the *list* xs, not the permutation, despite - -- initial appearances. - - perm_app_cons : Perm xs (app xs' ys') -> - Perm (Cons x xs) (app xs' (Cons x ys')); - perm_app_cons {xs'=Nil} {ys'=Nil} p = pskip p; - perm_app_cons {x} {xs=Cons x' xs} {xs'=Cons x' xs'} - (pskip p) = let prec = perm_app_cons {x=x} p in - perm_swapl (perm_rewrite_cons perm_id (perm_sym prec)); - perm_app_cons {xs=Cons x (Cons y _)} {xs'=Cons y (Cons x _)} - pswap = perm_swapl (perm_swapr (pskip (perm_swapl - (pskip (perm_app_cons perm_id))))); -- list is smaller! - perm_app_cons {xs=Cons x' xs} {xs'=Cons x' xs'} - (ptrans p1 p2) = perm_swapl (pskip (perm_app_cons - (perm_add_cons (ptrans p1 p2)))); -- list is smaller! - - -- Again by induction on the list xs. Maybe there are shorter proofs, - -- but it doesn't really matter, we're not going to run them... - - perm_app_swap : Perm (app xs ys) zs -> Perm (app ys xs) zs; - perm_app_swap {xs=Nil} p ?= p; [papp_swap_nil] - perm_app_swap {xs=Cons x xs} {zs=Cons x zs} - (pskip p) = perm_sym - (perm_app_cons (perm_sym (perm_app_swap p))); - perm_app_swap {xs=Cons x (Cons y _)} - pswap = perm_swapr (perm_sym - (perm_app_cons - (perm_rewrite_cons - (perm_app_cons perm_id) (perm_app_swap perm_id)))); - perm_app_swap {xs=Cons x xs} {zs=Cons z zs} - (ptrans p1 p2) = perm_sym (perm_cons_move - (perm_sym (perm_rewrite_cons - (ptrans p1 p2) (perm_app_swap perm_id)))); - -} - - -papp_cons proof { - %intro a; - %intro; - %refine ptrans; - %fill (app X xs'); - %refine ptrans; - %fill (app X ys'); - %fill r1; - %fill perm_app_head X (perm_sym p'); - %fill r2; - %qed; -}; - -papp_swap_nil proof { - %intro; - %use value; - %fill app_Nil X1; - %qed; -}; diff --git a/lib/prelude.idr b/lib/prelude.idr --- a/lib/prelude.idr +++ b/lib/prelude.idr @@ -1,121 +1,270 @@ --- malloc evaluates an expression using a manual allocator, allocating 'bytes' --- Needs to be compiled specially, naturally. +module prelude -malloc : Int -> a -> a; -malloc bytes val = val; +import builtins +import io -%freeze malloc; +import prelude.cast +import prelude.nat +import prelude.fin +import prelude.list +import prelude.maybe +import prelude.monad +import prelude.applicative +import prelude.either +import prelude.vect +import prelude.strings +import prelude.char --- Used by the 'believe' tactic to make a temporary proof. Programs --- using this are not to be trusted! (Or maybe use externally trusted code) --- Generate a refl so that __eq_repl can reduce. +%access public -__Suspend_Disbelief : (m:A) -> (n:A) -> (n = m); -__Suspend_Disbelief m n = __Prove_Anything _ _ (refl n); +-- Show and instances -flip : (a -> b -> c) -> b -> a -> c; -flip f x y = f y x; +class Show a where + show : a -> String -infixl 5 ==, /=, ==.; -infixl 6 <, <=, >, >=, <., <=., >., >=.; -infixl 7 <<, >>; -infixl 8 +,-,++,+.,-.; -infixl 9 *,/,*.,/.; +instance Show Nat where + show O = "O" + show (S k) = "s" ++ show k --- Integer primitives +instance Show Int where + show = prim__intToStr -(+) : Int -> Int -> Int; [inline] -(+) x y = __addInt x y; +instance Show Integer where + show = prim__bigIntToStr -(-) : Int -> Int -> Int; [inline] -(-) x y = __subInt x y; +instance Show Float where + show = prim__floatToStr -(*) : Int -> Int -> Int; [inline] -(*) x y = __mulInt x y; +instance Show Char where + show x = strCons x "" -(/) : Int -> Int -> Int; [inline] -(/) x y = __divInt x y; +instance Show String where + show = id -mod : Int -> Int -> Int; [inline] -mod x y = __modInt x y; +instance Show Bool where + show True = "True" + show False = "False" -(<) : Int -> Int -> Bool; [inline] -(<) x y = __intlt x y; +instance (Show a, Show b) => Show (a, b) where + show (x, y) = "(" ++ show x ++ ", " ++ show y ++ ")" -(<=) : Int -> Int -> Bool; [inline] -(<=) x y = __intleq x y; +instance Show a => Show (List a) where + show xs = "[" ++ show' xs ++ "]" where + show' : Show a => List a -> String + show' [] = "" + show' [x] = show x + show' (x :: xs) = show x ++ ", " ++ show' xs -(>) : Int -> Int -> Bool; [inline] -(>) x y = __intgt x y; +instance Show a => Show (Vect a n) where + show xs = "[" ++ show' xs ++ "]" where + show' : Show a => Vect a n -> String + show' [] = "" + show' [x] = show x + show' (x :: xs) = show x ++ ", " ++ show' xs -(>=) : Int -> Int -> Bool; [inline] -(>=) x y = __intgeq x y; +instance Show a => Show (Maybe a) where + show Nothing = "Nothing" + show (Just x) = "Just " ++ show x -(==) : Int -> Int -> Bool; [inline] -(==) x y = __eq x y; +---- Monad instances -(/=) : Int -> Int -> Bool; [inline] -(/=) x y = not (__eq x y); +instance Monad IO where + return t = io_return t + b >>= k = io_bind b k -(<<) : Int -> Int -> Int; [inline] -(<<) x y = __shl x y; +instance Monad Maybe where + return t = Just t -(>>) : Int -> Int -> Int; [inline] -(>>) x y = __shr x y; + Nothing >>= k = Nothing + (Just x) >>= k = k x --- Floating point primitives +instance MonadPlus Maybe where + mzero = Nothing -(+.) : Float -> Float -> Float; [inline] -(+.) x y = __addFloat x y; + mplus (Just x) _ = Just x + mplus Nothing (Just y) = Just y + mplus Nothing Nothing = Nothing -(-.) : Float -> Float -> Float; [inline] -(-.) x y = __subFloat x y; +instance Monad List where + return x = [x] + m >>= f = concatMap f m -(*.) : Float -> Float -> Float; [inline] -(*.) x y = __mulFloat x y; +instance MonadPlus List where + mzero = [] + mplus = app -(/.) : Float -> Float -> Float; [inline] -(/.) x y = __divFloat x y; +---- Functor instances -(<.) : Float -> Float -> Bool; [inline] -(<.) x y = __floatlt x y; +instance Functor Maybe where + fmap f (Just x) = Just (f x) + fmap f Nothing = Nothing -(<=.) : Float -> Float -> Bool; [inline] -(<=.) x y = __floatleq x y; +instance Functor List where + fmap = map -(>.) : Float -> Float -> Bool; [inline] -(>.) x y = __floatgt x y; +---- Applicative instances -(>=.) : Float -> Float -> Bool; [inline] -(>=.) x y = __floatgeq x y; +instance Applicative Maybe where + pure = Just -(==.) : Float -> Float -> Bool; [inline] -(==.) x y = __feq x y; + (Just f) <$> (Just a) = Just (f a) + Nothing <$> Nothing = Nothing --- String primitives -(++) : String -> String -> String; [inline] -(++) x y = __concat x y; +---- some mathematical operations +%include "math.h" +%lib "m" --- Function composition +exp : Float -> Float +exp x = prim__floatExp x -infixl 9 .; +log : Float -> Float +log x = prim__floatLog x -(.) : (b -> c) -> (a -> b) -> a -> c; -(.) f g x = f (g x); +pi : Float +pi = 3.141592653589793 -fst : (a & b) -> a; [inline] -fst (x, y) = x; +sin : Float -> Float +sin x = prim__floatSin x -snd : (a & b) -> b; [inline] -snd (x, y) = y; +cos : Float -> Float +cos x = prim__floatCos x -include "nat.idr"; -include "maybe.idr"; -include "io.idr"; -include "either.idr"; -include "tactics.idr"; -include "vect.idr"; -include "string.idr"; +tan : Float -> Float +tan x = prim__floatTan x + +asin : Float -> Float +asin x = prim__floatASin x + +acos : Float -> Float +acos x = prim__floatACos x + +atan : Float -> Float +atan x = prim__floatATan x + +sqrt : Float -> Float +sqrt x = prim__floatSqrt x + +floor : Float -> Float +floor x = prim__floatFloor x + +ceiling : Float -> Float +ceiling x = prim__floatCeil x + +---- Ranges + +count : Num a => a -> a -> a -> List a +count a inc b = if a <= b then a :: count (a + inc) inc b + else [] + +syntax "[" [start] ".." [end] "]" + = count start 1 end +syntax "[" [start] "," [next] ".." [end] "]" + = count start (next - start) end + +---- More utilities + +flip : (a -> b -> c) -> b -> a -> c +flip f x y = f y x + +sum : Num a => List a -> a +sum = foldl (+) 0 + +prod : Num a => List a -> a +prod = foldl (*) 1 + +---- some basic io + +putStr : String -> IO () +putStr x = mkForeign (FFun "putStr" [FString] FUnit) x + +putStrLn : String -> IO () +putStrLn x = putStr (x ++ "\n") + +print : Show a => a -> IO () +print x = putStrLn (show x) + +getLine : IO String +getLine = mkForeign (FFun "readStr" Nil FString) + +putChar : Char -> IO () +putChar c = mkForeign (FFun "putchar" [FChar] FUnit) c + +getChar : IO Char +getChar = mkForeign (FFun "getchar" [] FChar) + +---- some basic file handling + +abstract +data File = FHandle Ptr + +do_fopen : String -> String -> IO Ptr +do_fopen f m = mkForeign (FFun "fileOpen" [FString, FString] FPtr) f m + +fopen : String -> String -> IO File +fopen f m = do h <- do_fopen f m + return (FHandle h) + +data Mode = Read | Write | ReadWrite + +openFile : String -> Mode -> IO File +openFile f m = fopen f (modeStr m) where + modeStr : Mode -> String + modeStr Read = "r" + modeStr Write = "w" + modeStr ReadWrite = "r+" + +do_fclose : Ptr -> IO () +do_fclose h = mkForeign (FFun "fileClose" [FPtr] FUnit) h + +closeFile : File -> IO () +closeFile (FHandle h) = do_fclose h + +do_fread : Ptr -> IO String +do_fread h = mkForeign (FFun "freadStr" [FPtr] FString) h + +fread : File -> IO String +fread (FHandle h) = do_fread h + +do_fwrite : Ptr -> String -> IO () +do_fwrite h s = mkForeign (FFun "fputStr" [FPtr, FString] FUnit) h s + +fwrite : File -> String -> IO () +fwrite (FHandle h) s = do_fwrite h s + +do_feof : Ptr -> IO Int +do_feof h = mkForeign (FFun "feof" [FPtr] FInt) h + +feof : File -> IO Bool +feof (FHandle h) = do eof <- do_feof h + return (not (eof == 0)) + +nullPtr : Ptr -> IO Bool +nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p + return (ok /= 0); + +validFile : File -> IO Bool +validFile (FHandle h) = do x <- nullPtr h + return (not x) + +while : |(test : IO Bool) -> |(body : IO ()) -> IO () +while t b = do v <- t + if v then do b + while t b + else return () + + +readFile : String -> IO String +readFile fn = do h <- openFile fn Read + c <- readFile' h "" + closeFile h + return c + where + readFile' : File -> String -> IO String + readFile' h contents = + do x <- feof h + if not x then do l <- fread h + readFile' h (contents ++ l) + else return contents diff --git a/lib/prelude/applicative.idr b/lib/prelude/applicative.idr new file mode 100644 --- /dev/null +++ b/lib/prelude/applicative.idr @@ -0,0 +1,13 @@ +module prelude.applicative + +import builtins + +---- Applicative functors/Idioms + +infixl 2 <$> + +class Applicative (f : Set -> Set) where + pure : a -> f a + (<$>) : f (a -> b) -> f a -> f b + + diff --git a/lib/prelude/cast.idr b/lib/prelude/cast.idr new file mode 100644 --- /dev/null +++ b/lib/prelude/cast.idr @@ -0,0 +1,49 @@ +module prelude.cast + +class Cast from to where + cast : from -> to + +-- String casts + +instance Cast String Int where + cast = prim__strToInt + +instance Cast String Float where + cast = prim__strToFloat + +instance Cast String Integer where + cast = prim__strToBigInt + +-- Int casts + +instance Cast Int String where + cast = prim__intToStr + +instance Cast Int Float where + cast = prim__intToFloat + +instance Cast Int Integer where + cast = prim__intToBigInt + +instance Cast Int Char where + cast = prim__intToChar + +-- Float casts + +instance Cast Float String where + cast = prim__floatToStr + +instance Cast Float Int where + cast = prim__floatToInt + +-- Integer casts + +instance Cast Integer String where + cast = prim__bigIntToStr + +-- Char casts + +instance Cast Char Int where + cast = prim__charToInt + + diff --git a/lib/prelude/char.idr b/lib/prelude/char.idr new file mode 100644 --- /dev/null +++ b/lib/prelude/char.idr @@ -0,0 +1,34 @@ +module prelude.char + +import builtins + +isUpper : Char -> Bool +isUpper x = x >= 'A' && x <= 'Z' + +isLower : Char -> Bool +isLower x = x >= 'a' && x <= 'z' + +isAlpha : Char -> Bool +isAlpha x = isUpper x || isLower x + +isDigit : Char -> Bool +isDigit x = (x >= '0' && x <= '9') + +isAlphaNum : Char -> Bool +isAlphaNum x = isDigit x || isAlpha x + +isSpace : Char -> Bool +isSpace x = x == ' ' || x == '\t' || x == '\r' || + x == '\n' || x == '\f' || x == '\v' || + x == '\xa0' + +toUpper : Char -> Char +toUpper x = if (isLower x) + then (prim__intToChar (prim__charToInt x - 32)) + else x + +toLower : Char -> Char +toLower x = if (isUpper x) + then (prim__intToChar (prim__charToInt x + 32)) + else x + diff --git a/lib/prelude/either.idr b/lib/prelude/either.idr new file mode 100644 --- /dev/null +++ b/lib/prelude/either.idr @@ -0,0 +1,13 @@ +module prelude.either + +import builtins + +data Either a b = Left a | Right b + +choose : (b : Bool) -> Either (so b) (so (not b)) +choose True = Left oh +choose False = Right oh + +either : Either a b -> (a -> c) -> (b -> c) -> c +either (Left x) l r = l x +either (Right x) l r = r x diff --git a/lib/prelude/fin.idr b/lib/prelude/fin.idr new file mode 100644 --- /dev/null +++ b/lib/prelude/fin.idr @@ -0,0 +1,13 @@ +module prelude.fin + +import prelude.nat + +data Fin : Nat -> Set where + fO : Fin (S k) + fS : Fin k -> Fin (S k) + +instance Eq (Fin n) where + fO == fO = True + (fS k) == (fS k') = k == k' + _ == _ = False + diff --git a/lib/prelude/list.idr b/lib/prelude/list.idr new file mode 100644 --- /dev/null +++ b/lib/prelude/list.idr @@ -0,0 +1,104 @@ +module prelude.list + +import prelude.maybe +import builtins + +%access public + +infixr 7 :: + +data List a = Nil | (::) a (List a) + +rev : List a -> List a +rev xs = revAcc [] xs where + revAcc : List a -> List a -> List a + revAcc acc [] = acc + revAcc acc (x :: xs) = revAcc (x :: acc) xs + +app : List a -> List a -> List a +app [] xs = xs +app (x :: xs) ys = x :: app xs ys + +length : List a -> Int +length [] = 0 +length (x :: xs) = 1 + length xs + +take : Int -> List a -> List a +take 0 xs = [] +take n [] = [] +take n (x :: xs) = x :: take (n-1) xs + +drop : Int -> List a -> List a +drop 0 xs = xs +drop n [] = [] +drop n (x :: xs) = drop (n-1) xs + +map : (a -> b) -> List a -> List b +map f [] = [] +map f (x :: xs) = f x :: map f xs + +concatMap : (a -> List b) -> List a -> List b +concatMap f [] = [] +concatMap f (x :: xs) = app (f x) (concatMap f xs) + +mapMaybe : (a -> Maybe b) -> List a -> List b +mapMaybe f [] = [] +mapMaybe f (x :: xs) = case f x of + Nothing => mapMaybe f xs + Just v => v :: mapMaybe f xs + +foldl : (a -> b -> a) -> a -> List b -> a +foldl f a [] = a +foldl f a (x :: xs) = foldl f (f a x) xs + +foldr : (a -> b -> b) -> b -> List a -> b +foldr f b [] = b +foldr f b (x :: xs) = f x (foldr f b xs) + +filter : (y -> Bool) -> List y -> List y +filter pred [] = [] +filter pred (x :: xs) = if (pred x) then (x :: filter pred xs) + else (filter pred xs) + +elem : Eq a => a -> List a -> Bool +elem x [] = False +elem x (y :: ys) = if (x == y) then True else (elem x ys) + +lookup : Eq k => k -> List (k, v) -> Maybe v +lookup k [] = Nothing +lookup k ((x, v) :: xs) = if (x == k) then (Just v) else (lookup k xs) + +sort : Ord a => List a -> List a +sort [] = [] +sort [x] = [x] +sort xs = let (x, y) = split xs in + merge (sort x) (sort y) where + splitrec : List a -> List a -> (List a -> List a) -> (List a, List a) + splitrec (_ :: _ :: xs) (y :: ys) zs = splitrec xs ys (zs . ((::) y)) + splitrec _ ys zs = (zs [], ys) + + split : List a -> (List a, List a) + split xs = splitrec xs xs id + + merge : Ord a => List a -> List a -> List a + merge xs [] = xs + merge [] ys = ys + merge (x :: xs) (y :: ys) = if (x < y) then (x :: merge xs (y :: ys)) + else (y :: merge (x :: xs) ys) + +span : (a -> Bool) -> List a -> (List a, List a) +span p [] = ([], []) +span p (x :: xs) with (p x) + | True with (span p xs) + | (ys, zs) = (x :: ys, zs) + | False = ([], x :: xs) + +break : (a -> Bool) -> List a -> (List a, List a) +break p = span (not . p) + +split : (a -> Bool) -> List a -> List (List a) +split p [] = [] +split p xs = case break p xs of + (chunk, []) => [chunk] + (chunk, (c :: rest)) => chunk :: split p rest + diff --git a/lib/prelude/maybe.idr b/lib/prelude/maybe.idr new file mode 100644 --- /dev/null +++ b/lib/prelude/maybe.idr @@ -0,0 +1,12 @@ +module prelude.maybe + +data Maybe a = Nothing | Just a + +maybe : |(def : b) -> (a -> b) -> Maybe a -> b +maybe n j Nothing = n +maybe n j (Just x) = j x + +maybe_bind : Maybe a -> (a -> Maybe b) -> Maybe b +maybe_bind Nothing k = Nothing +maybe_bind (Just x) k = k x + diff --git a/lib/prelude/monad.idr b/lib/prelude/monad.idr new file mode 100644 --- /dev/null +++ b/lib/prelude/monad.idr @@ -0,0 +1,44 @@ +module prelude.monad + +-- Monads and Functors + +import builtins + +%access public + +infixl 5 >>= + +class Monad (m : Set -> Set) where + return : a -> m a + (>>=) : m a -> (a -> m b) -> m b + +class Functor (f : Set -> Set) where + fmap : (a -> b) -> f a -> f b + +class Monad m => MonadPlus (m : Set -> Set) where + mplus : m a -> m a -> m a + mzero : m a + +guard : MonadPlus m => Bool -> m () +guard True = return () +guard False = mzero + +when : Monad m => Bool -> m () -> m () +when True f = f +when False _ = return () + +sequence : Monad m => List (m a) -> m (List a) +sequence [] = return [] +sequence (x :: xs) = [ x' :: xs' | x' <- x, xs' <- sequence xs ] + +sequence_ : Monad m => List (m a) -> m () +sequence_ [] = return () +sequence_ (x :: xs) = do x; sequence_ xs + +mapM : Monad m => (a -> m b) -> List a -> m (List b) +mapM f xs = sequence (map f xs) + +mapM_ : Monad m => (a -> m b) -> List a -> m () +mapM_ f xs = sequence_ (map f xs) + + diff --git a/lib/prelude/nat.idr b/lib/prelude/nat.idr new file mode 100644 --- /dev/null +++ b/lib/prelude/nat.idr @@ -0,0 +1,124 @@ +module prelude.nat + +import builtins +import prelude.cast + +%access public + +data Nat = O | S Nat + +instance Cast Nat Int where + cast O = 0 + cast (S k) = 1 + cast k + +plus : Nat -> Nat -> Nat +plus O y = y +plus (S k) y = S (plus k y) + +eqRespS : m = n -> S m = S n +eqRespS refl = refl + +eqRespS' : S m = S n -> m = n +eqRespS' refl = refl + +sub : Nat -> Nat -> Nat +sub O y = O +sub (S k) (S y) = sub k y +sub x O = x + +mult : Nat -> Nat -> Nat +mult O y = O +mult (S k) y = plus y (mult k y) + +instance Eq Nat where + O == O = True + (S x) == (S y) = x == y + O == (S y) = False + (S x) == O = False + +instance Ord Nat where + compare O O = EQ + compare O (S k) = LT + compare (S k) O = GT + compare (S x) (S y) = compare x y + +instance Num Nat where + (+) = plus + (-) = sub + (*) = mult + + fromInteger 0 = O + fromInteger n = if (n > 0) then (S (fromInteger (n-1))) else O + +plusnO : (m : Nat) -> m + O = m +plusnO O = refl +plusnO (S k) = eqRespS (plusnO k) + +plusn_Sm : (n, m : Nat) -> (plus n (S m)) = S (plus n m) +plusn_Sm O m = refl +plusn_Sm (S j) m = eqRespS (plusn_Sm _ _) + +plus_commutes : (n : Nat) -> (m : Nat) -> n + m = m + n +plus_commutes O m = sym (plusnO m) +plus_commutes (S k) m = let ih = plus_commutes k m in ?plus_commutes_Sk + +plus_commutes_Sk = proof { + intros; + refine sym; + rewrite sym ih; + rewrite plusn_Sm m k; + trivial; +} + +plus_assoc : (n, m, p : Nat) -> n + (m + p) = (n + m) + p +plus_assoc O m p = refl +plus_assoc (S k) m p = let ih = plus_assoc k m p in eqRespS ih + +data Cmp : Nat -> Nat -> Set where + cmpLT : (y : Nat) -> Cmp x (x + S y) + cmpEQ : Cmp x x + cmpGT : (x : Nat) -> Cmp (y + S x) y + +cmp : (n, m : Nat) -> Cmp n m +cmp O O = cmpEQ +cmp (S n) O = cmpGT _ +cmp O (S n) = cmpLT _ +cmp (S x) (S y) with (cmp x y) + cmp (S x) (S x) | cmpEQ = cmpEQ + cmp (S (y + S x)) (S y) | cmpGT _ = cmpGT _ + cmp (S x) (S (x + S y)) | cmpLT _ = cmpLT _ + +multnO : (n : Nat) -> (n * O) = O +multnO O = refl +multnO (S k) = multnO k + +multn_Sm : (n, m : Nat) -> n * S m = n + n * m +multn_Sm O m = refl +multn_Sm (S k) m = let ih = multn_Sm k m in ?multnSmSk + +mult_commutes : (n, m : Nat) -> n * m = m * n +mult_commutes O m = ?mult_commO +mult_commutes (S k) m = let ih = mult_commutes k m in ?mult_commSk + +mult_commSk = proof { + intros; + rewrite sym ih; + rewrite multn_Sm m k; + trivial; +} + +mult_commO = proof { + intro; + rewrite multnO m; + trivial; +} + +multnSmSk = proof { + intros; + rewrite plus_commutes (mult k m) m; + rewrite sym (plus_assoc k (mult k m) m); + rewrite ih; + rewrite plus_commutes m (mult k (S m)); + trivial; +} + diff --git a/lib/prelude/strings.idr b/lib/prelude/strings.idr new file mode 100644 --- /dev/null +++ b/lib/prelude/strings.idr @@ -0,0 +1,64 @@ +module prelude.strings + +import builtins +import prelude.list +import prelude.char +import prelude.cast + +-- Some more complex string operations + +data StrM : String -> Set where + StrNil : StrM "" + StrCons : (x : Char) -> (xs : String) -> StrM (strCons x xs) + +strHead' : (x : String) -> so (not (x == "")) -> Char +strHead' x p = prim__strHead x + +strTail' : (x : String) -> so (not (x == "")) -> String +strTail' x p = prim__strTail x + +-- we need the 'believe_me' because the operations are primitives + +strM : (x : String) -> StrM x +strM x with (choose (not (x == ""))) + strM x | (Left p) = believe_me (StrCons (strHead' x p) (strTail' x p)) + strM x | (Right p) = believe_me StrNil + +unpack : String -> List Char +unpack s with (strM s) + unpack "" | StrNil = [] + unpack (strCons x xs) | (StrCons _ _) = x :: unpack xs + +pack : List Char -> String +pack [] = "" +pack (x :: xs) = strCons x (pack xs) + +instance Cast String (List Char) where + cast = unpack + +instance Cast (List Char) String where + cast = pack + +span : (Char -> Bool) -> String -> (String, String) +span p xs with (strM xs) + span p "" | StrNil = ("", "") + span p (strCons x xs) | (StrCons _ _) with (p x) + | True with (span p xs) + | (ys, zs) = (strCons x ys, zs) + | False = ("", strCons x xs) + +break : (Char -> Bool) -> String -> (String, String) +break p = span (not . p) + +split : (Char -> Bool) -> String -> List String +split p xs = map pack (split p (unpack xs)) + +ltrim : String -> String +ltrim xs with (strM xs) + ltrim "" | StrNil = "" + ltrim (strCons x xs) | StrCons _ _ + = if (isSpace x) then (ltrim xs) else (strCons x xs) + +trim : String -> String +trim xs = ltrim (rev (ltrim (rev xs))) + diff --git a/lib/prelude/vect.idr b/lib/prelude/vect.idr new file mode 100644 --- /dev/null +++ b/lib/prelude/vect.idr @@ -0,0 +1,56 @@ +module prelude.vect + +import prelude.nat +import prelude.fin + +%access public + +infixr 7 :: + +data Vect : Set -> Nat -> Set where + Nil : Vect a O + (::) : a -> Vect a k -> Vect a (S k) + +tail : Vect a (S n) -> Vect a n +tail (x :: xs) = xs + +lookup : Fin n -> Vect a n -> a +lookup fO (x :: xs) = x +lookup (fS k) (x :: xs) = lookup k xs +lookup fO [] impossible +lookup (fS _) [] impossible + +app : Vect a n -> Vect a m -> Vect a (n + m) +app [] ys = ys +app (x :: xs) ys = x :: app xs ys + +filter : (a -> Bool) -> Vect a n -> (p ** Vect a p) +filter p [] = ( _ ** [] ) +filter p (x :: xs) + = let (_ ** xs') = filter p xs in + if (p x) then ( _ ** x :: xs' ) else ( _ ** xs' ) + +map : (a -> b) -> Vect a n -> Vect b n +map f [] = [] +map f (x :: xs) = f x :: map f xs + +rev : Vect a n -> Vect a n +rev xs = revAcc [] xs where + revAcc : Vect a n -> Vect a m -> Vect a (n + m) + revAcc acc [] ?= acc + revAcc acc (x :: xs) ?= revAcc (x :: acc) xs + +---------- Proofs ---------- + +revAcc_lemma_2 = proof { + intros; + rewrite sym (plusn_Sm n k); + exact value; +} + +revAcc_lemma_1 = proof { + intros; + rewrite sym (plusnO n); + exact value; +} + diff --git a/lib/state.idr b/lib/state.idr deleted file mode 100644 --- a/lib/state.idr +++ /dev/null @@ -1,29 +0,0 @@ -namespace State { - - State : Set -> Set -> Set; - State s a = s -> (a & s); - - bind : State s a -> (a -> State s b) -> State s b; - bind fa k state with fa state { - | (av, state') = k av state'; - } - - ret : a -> State s a; - ret av state = (av, state); - - get : State s s; - get state = (state, state); - - put : s -> State s (); - put state _ = (II, state); - - runState : State s a -> s -> (a & s); - runState s init = s init; - - execState : State s a -> s -> s; - execState s init = snd (runState s init); - - evalState : State s a -> s -> a; - evalState s init = fst (runState s init); - -} diff --git a/lib/string.idr b/lib/string.idr deleted file mode 100644 --- a/lib/string.idr +++ /dev/null @@ -1,247 +0,0 @@ -include "list.idr"; - -strLen: String -> Int; [inline] -strLen str = __strlen str; - -strEq: String -> String -> Bool; [inline] -strEq s1 s2 = __strEq s1 s2; - -charEq : Char -> Char -> Bool; [inline] -charEq c1 c2 = __charToInt c1 == __charToInt c2; - -concat: String -> String -> String; [inline] -concat s1 s2 = __concat s1 s2; - -strNull: String -> Bool; [inline] -strNull s = strEq s ""; - -strHead: String -> Maybe Char; [inline] -strHead s = if (strNull s) then Nothing else (Just (__strHead s)); - -strTail: String -> Maybe String; [inline] -strTail s = if (strNull s) then Nothing else (Just (__strTail s)); - -strRev : String -> String; [inline] -strRev s = __strRev s; - -substr : String -> Int -> Int -> String; [inline] -substr s start len = __substr s start len; - -strFind : String -> Char -> Int; [inline] -strFind s c = __strFind s c; - -strSplit : Char -> String -> (String & String); -strSplit c str = let idx = strFind str c in - if (idx == (-1)) then (str, "") else - (substr str 0 idx, substr str (idx+1) (strLen str - (idx+1))); - --- Some more, faster, string manipulations - -strHead' : (x:String) -> (so (not (strNull x))) -> Char; -strHead' x p = __strHead x; - -strTail' : (x:String) -> (so (not (strNull x))) -> String; -strTail' x p = __strTail x; - -strCons: Char -> String -> String; [inline] -strCons c s = __strCons c s; - -strUncons: String -> Maybe (Char & String); [inline] -strUncons s with (strHead s, strTail s) { - | (Just h, Just t) = Just (h, t); - | (Nothing, Nothing) = Nothing; -} - -{-- A view of strings, for better, faster, pattern matching --} - -data StrM : String -> Set where - StrNil : StrM "" - | StrCons : (x:Char) -> (xs:String) -> StrM (strCons x xs); - -strM : (x:String) -> StrM x; -strM x with choose (strNull x) { - | Left p ?= StrCons (strHead' x p) (strTail' x p); [strMleft] - | Right p ?= StrNil; [strMright] -} - -strMright proof { - %intro; - %believe value; -- it's a primitive operation, we have to believe it! - %qed; -}; - -strMleft proof { - %intro; - %believe value; -- it's a primitive operation, we have to believe it! - %qed; -}; - - -charAt: Int -> String -> Maybe Char; [inline] -charAt x str = - if (strLen str > x && x >= 0) then (Just (__strgetIdx str x)) - else Nothing; - -showInt: Int -> String; [inline] -showInt x = __toString x; - -readInt: String -> Maybe Int; -readInt str = let x = __toInt str - in if (strEq str (showInt x)) - then (Just x) - else Nothing; - -showNat: Nat -> String; -showNat n = __toString (natToInt n); - -readNat: String -> Maybe Nat; -readNat str with readInt str { - | Just x = if (x >= 0) then (Just (intToNat x)) else Nothing; - | Nothing = Nothing; -} - -showFloat: Float -> String; -showFloat n = __floatToString n; - -strToList: String -> List Char; -strToList s with strUncons s { - | Just (h, t) = Cons h (strToList t); - | Nothing = Nil; -} - -listToStr: List Char -> String; -listToStr = foldr strCons ""; - --- TODO if the change to the parser breaks things, the sigma pattern will --- need parens around -strToVect: String -> (n ** Vect Char n); -strToVect s with strUncons s { - | Just (c, cs) with strToVect cs { - | <| cs' |> = <| c :: cs' |>; - } - | Nothing = <| VNil |>; -} - -vectToStr: Vect Char n -> String; -vectToStr (h :: t) = strCons h (vectToStr t); -vectToStr VNil = ""; - - -data StrCmp = StrLT | StrEQ | StrGT; -strCmp: String -> String -> StrCmp; -strCmp s t = - if (__strLT s t) then StrLT - else if (strEq s t) then StrEQ - else StrGT; - -strSpan' : (Char -> Bool) -> String -> String -> (String & String); -strSpan' p str acc with strM str { - strSpan' p "" acc | StrNil - = (strRev acc, ""); - strSpan' p (strCons c cs) acc | StrCons _ _ - = if (p c) then (strSpan' p cs (strCons c acc)) - else (strRev acc, (strCons c cs)); -} - -strSpan : (Char -> Bool) -> String -> (String & String); -strSpan p str = strSpan' p str ""; - --- TODO: A collection of these in a Char library. - -isSpace : Char -> Bool; -isSpace ' ' = True; -isSpace '\t' = True; -isSpace '\r' = True; -isSpace '\n' = True; -isSpace _ = False; - -isNL : Char -> Bool; -isNL '\r' = True; -isNL '\n' = True; -isNL _ = False; - -isAlpha : Char -> Bool; -isAlpha x = let a = __charToInt 'a' in - let z = __charToInt 'z' in - let A = __charToInt 'A' in - let Z = __charToInt 'Z' in - let x' = __charToInt x in - (x' >= a && x' <= z) || (x' >= A && x' <= Z); - -isDigit : Char -> Bool; -isDigit x = let a = __charToInt '0' in - let z = __charToInt '9' in - let x' = __charToInt x in - (x' >= a && x' <= z); - -words : String -> List String; -words str with (strSpan (not . isSpace) str) { - | ("", "") = Nil; - | (word, rest) with choose (strNull rest) { - | Left rp with choose (strNull word) { - | Left wp = Cons word (words (strTail' rest rp)); - | Right wp = words (strTail' rest rp); - } - | Right rp = Cons word Nil; - } -} - -lines : String -> List String; -lines str with (strSpan (not . isNL) str) { - | ("", "") = Nil; - | (line, rest) with choose (strNull rest) { - | Left rp with choose (strNull line) { - | Left wp = Cons line (lines (strTail' rest rp)); - | Right wp = lines (strTail' rest rp); - } - | Right rp = Cons line Nil; - } -} - --- Generic version of lines/words - -splitBy : (Char -> Bool) -> String -> List String; -splitBy p str with (strSpan (not . p) str) { - | ("", "") = Nil; - | (word, rest) with choose (strNull rest) { - | Left rp with choose (strNull word) { - | Left wp = Cons word (splitBy p (strTail' rest rp)); - | Right wp = splitBy p (strTail' rest rp); - } - | Right rp = Cons word Nil; - } -} - -unlines : List String -> String; -unlines Nil = ""; -unlines (Cons x xs) = x ++ "\n" ++ unlines xs; - -unwords : List String -> String; -unwords Nil = ""; -unwords (Cons x Nil) = x; -unwords (Cons x xs) = x ++ " " ++ unwords xs; - -trimLeft : String -> String; -trimLeft str with (strSpan isSpace str) { - | (spcs, rest) = rest; -} - -trimRight : String -> String; -trimRight x = strRev (trimLeft (strRev x)); - -trim : String -> String; -trim x = trimLeft (strRev (trimLeft (strRev x))); - -mapStr : (Char -> Char) -> String -> String; -mapStr f str with strM str { - mapStr f "" | StrNil = ""; - mapStr f (strCons c cs) | StrCons _ _ = strCons (f c) (mapStr f cs); -} - -toLower : Char -> Char; -toLower x = let xi = __charToInt x in - let Ai = __charToInt 'A' in - let ai = __charToInt 'a' in - let Zi = __charToInt 'Z' in - if (xi>=Ai && xi<=Zi) then (__intToChar (xi+ai-Ai)) else x; - diff --git a/lib/system.idr b/lib/system.idr --- a/lib/system.idr +++ b/lib/system.idr @@ -1,18 +1,27 @@ --- System/OS interaction functions +module system -namespace System { +import prelude - numArgs = mkForeign (FFun "epic_numArgs" [] FInt); [%eval] - getArgn = mkForeign (FFun "epic_getArg" [FInt] FStr); [%eval] +%access public - getArgs' : List String -> Int -> IO (List String); - getArgs' acc 0 = return acc; - getArgs' acc n = do { arg <- getArgn (n-1); - getArgs' (Cons arg acc) (n-1); - }; +getArgs : IO (List String) +getArgs = do n <- numArgs + ga' [] 0 n + where + numArgs : IO Int + numArgs = mkForeign (FFun "epic_numArgs" [] FInt) - getArgs : IO (List String); - getArgs = do { num <- numArgs; - getArgs' [] num; }; + getArg : Int -> IO String + getArg x = mkForeign (FFun "epic_getArg" [FInt] FString) x -} + ga' : List String -> Int -> Int -> IO (List String) + ga' acc i n = if (i == n) then (return $ rev acc) else + do arg <- getArg i + ga' (arg :: acc) (i+1) n + +getEnv : String -> IO String +getEnv x = mkForeign (FFun "getenv" [FString] FString) x + +exit : Int -> IO () +exit code = mkForeign (FFun "exit" [FInt] FUnit) code + diff --git a/lib/tactics.idr b/lib/tactics.idr deleted file mode 100644 --- a/lib/tactics.idr +++ /dev/null @@ -1,11 +0,0 @@ -data Tactic : Set where - TFill : {a:Set} -> a -> Tactic - | TRefine : String -> Tactic - | TTrivial : Tactic - | TDecide : {a:Set} -> Maybe a -> Tactic - | TSearchContext : Tactic - | TTry : Tactic -> Tactic -> Tactic - | TSeq : Tactic -> Tactic -> Tactic - | TThen : Tactic -> Tactic -> Tactic - | TThenAll : Tactic -> Tactic -> Tactic - | TFail : String -> Tactic; diff --git a/lib/vect.idr b/lib/vect.idr deleted file mode 100644 --- a/lib/vect.idr +++ /dev/null @@ -1,71 +0,0 @@ -include "nat.idr"; - -infixr 5 ::; - -data Vect : Set -> Nat -> Set where - VNil : Vect A O - | (::) : A -> (Vect A k) -> (Vect A (S k)); - -data Fin : Nat -> Set where - fO : Fin (S k) - | fS : (Fin k) -> (Fin (S k)); - -finToNat : Fin k -> Nat; -finToNat fO = O; -finToNat (fS k) = S (finToNat k); - -natToFin : (x:Nat) -> Fin (S x); -natToFin O = fO; -natToFin (S k) = fS (natToFin k); - -ltFin : Fin n -> Fin n -> Bool; -ltFin fO (fS x) = True; -ltFin (fS x) fO = False; -ltFin fO fO = False; -ltFin (fS x) (fS y) = ltFin x y; - -vlookup : (Fin k) -> (Vect A k) -> A; -vlookup fO (x :: xs) = x; -vlookup (fS k) (x :: xs) = vlookup k xs; - -weakenFin : Fin n -> Fin (S n); -weakenFin fO = fO; -weakenFin (fS k) = fS (weakenFin k); - -vmap : (A->B) -> (Vect A n) -> (Vect B n); -vmap f VNil = VNil; -vmap f (x :: xs) = f x :: vmap f xs; - -vapp : (Vect A n) -> (Vect A m) -> (Vect A (plus n m)); -vapp VNil ys = ys; -vapp (x :: xs) ys = x :: vapp xs ys; - --- Membership predicate for vectors, and means to compute one. - -using (A:Set, n:Nat, i:Fin n, x:A, y:A, xs:Vect A n) { - - data ElemIs : (Fin n) -> A -> (Vect A n) -> Set where - first : (ElemIs fO x (x :: xs)) - | later : (ElemIs i x xs) -> (ElemIs (fS i) x (y :: xs)); -} - -elemIs : (i:Fin n) -> (xs:Vect A n) -> (ElemIs i (vlookup i xs) xs); -elemIs fO (x :: xs) = first; -elemIs (fS k) (x :: xs) = later (elemIs k xs); - -isElemAuxO : {x:A} -> {xs: Vect A n} -> - (y:A) -> - (eq: (Maybe (x=y))) -> - (Maybe (ElemIs fO x (y :: xs))); -isElemAuxO {x=y} y (Just (refl _)) = Just first; -isElemAuxO y Nothing = Nothing; - -isElem : (eq:(a:A)->(b:A)->(Maybe (a=b)))-> - (i:Fin n) -> (x:A) -> (xs:Vect A n) -> (Maybe (ElemIs i x xs)); -isElem eq i x VNil = Nothing; -isElem eq fO x (y :: xs) = isElemAuxO y (eq x y); -isElem eq (fS i) x (y :: xs) = mMap later (isElem eq i x xs); - -vfoldl : (a -> b -> a) -> a -> (Vect b n) -> a; -vfoldl f z VNil = z; -vfoldl f z (x :: xs) = vfoldl f (f z x) xs; diff --git a/src/Core/CaseTree.hs b/src/Core/CaseTree.hs new file mode 100644 --- /dev/null +++ b/src/Core/CaseTree.hs @@ -0,0 +1,216 @@ +module Core.CaseTree(CaseDef(..), SC(..), CaseAlt(..), CaseTree, + simpleCase, small) where + +import Core.TT + +import Control.Monad.State +import Debug.Trace + +data CaseDef = CaseDef [Name] SC + deriving Show + +data SC = Case Name [CaseAlt] + | STerm Term + | UnmatchedCase String -- error message + deriving Show +{-! +deriving instance Binary SC +!-} + +data CaseAlt = ConCase Name Int [Name] SC + | ConstCase Const SC + | DefaultCase SC + deriving Show +{-! +deriving instance Binary CaseAlt +!-} + +type CaseTree = SC +type Clause = ([Pat], Term) +type CS = Int + +-- simple terms can be inlined trivially - good for primitives in particular +small :: SC -> Bool +-- small (STerm t) = True +small _ = False + +simpleCase :: Bool -> Bool -> [(Term, Term)] -> CaseDef +simpleCase tc cover [] + = CaseDef [] (UnmatchedCase "No pattern clauses") +simpleCase tc cover cs + = let pats = map (\ (l, r) -> (toPats tc l, r)) cs + numargs = length (fst (head pats)) + ns = take numargs args + tree = evalState (match ns pats (defaultCase cover)) numargs in + CaseDef ns (prune tree) + where args = map (\i -> MN i "e") [0..] + defaultCase True = STerm Erased + defaultCase False = UnmatchedCase "Error" + +data Pat = PCon Name Int [Pat] + | PConst Const + | PV Name + | PAny + deriving Show + +-- If there are repeated variables, take the *last* one (could be name shadowing +-- in a where clause, so take the most recent). + +toPats :: Bool -> Term -> [Pat] +toPats tc f = reverse (toPat tc (getArgs f)) where + getArgs (App f a) = a : getArgs f + getArgs _ = [] + +toPat :: Bool -> [Term] -> [Pat] +toPat tc tms = evalState (mapM (\x -> toPat' x []) tms) [] + where + toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args + return $ PCon n t args' + -- Typecase + toPat' (P (TCon t a) n _) args | tc + = do args' <- mapM (\x -> toPat' x []) args + return $ PCon n t args' + toPat' (Constant IType) [] | tc = return $ PCon (UN "Int") 1 [] + toPat' (Constant FlType) [] | tc = return $ PCon (UN "Float") 2 [] + toPat' (Constant ChType) [] | tc = return $ PCon (UN "Char") 3 [] + toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 [] + toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 [] + toPat' (Constant BIType) [] | tc = return $ PCon (UN "Integer") 6 [] + + toPat' (P Bound n _) [] = do ns <- get + if n `elem` ns + then return PAny + else do put (n : ns) + return (PV n) + toPat' (App f a) args = toPat' f (a : args) + toPat' (Constant (I c)) [] = return $ PConst (I c) + toPat' _ _ = return PAny + + +data Partition = Cons [Clause] + | Vars [Clause] + +isVarPat (PV _ : ps , _) = True +isVarPat (PAny : ps , _) = True +isVarPat _ = False + +isConPat (PCon _ _ _ : ps, _) = True +isConPat (PConst _ : ps, _) = True +isConPat _ = False + +partition :: [Clause] -> [Partition] +partition [] = [] +partition ms@(m : _) + | isVarPat m = let (vars, rest) = span isVarPat ms in + Vars vars : partition rest + | isConPat m = let (cons, rest) = span isConPat ms in + Cons cons : partition rest +partition xs = error $ "Partition " ++ show xs + +match :: [Name] -> [Clause] -> SC -- error case + -> State CS SC +match [] (([], ret) : _) err = return $ STerm ret -- run out of arguments +match vs cs err = mixture vs (partition cs) err + +mixture :: [Name] -> [Partition] -> SC -> State CS SC +mixture vs [] err = return err +mixture vs (Cons ms : ps) err = do fallthrough <- mixture vs ps err + conRule vs ms fallthrough +mixture vs (Vars ms : ps) err = do fallthrough <- mixture vs ps err + varRule vs ms fallthrough + +data ConType = CName Name Int -- named constructor + | CConst Const -- constant, not implemented yet + +data Group = ConGroup ConType -- Constructor + [([Pat], Clause)] -- arguments and rest of alternative + +conRule :: [Name] -> [Clause] -> SC -> State CS SC +conRule (v:vs) cs err = do groups <- groupCons cs + caseGroups (v:vs) groups err + +caseGroups :: [Name] -> [Group] -> SC -> State CS SC +caseGroups (v:vs) gs err = do g <- altGroups gs + return $ Case v g + where + altGroups [] = return [DefaultCase err] + altGroups (ConGroup (CName n i) args : cs) + = do g <- altGroup n i args + rest <- altGroups cs + return (g : rest) + altGroups (ConGroup (CConst c) args : cs) + = do g <- altConstGroup c args + rest <- altGroups cs + return (g : rest) + + altGroup n i gs = do (newArgs, nextCs) <- argsToAlt gs + matchCs <- match (newArgs ++ vs) nextCs err + return $ ConCase n i newArgs matchCs + altConstGroup n gs = do (_, nextCs) <- argsToAlt gs + matchCs <- match vs nextCs err + return $ ConstCase n matchCs + +argsToAlt :: [([Pat], Clause)] -> State CS ([Name], [Clause]) +argsToAlt [] = return ([], []) +argsToAlt rs@((r, m) : _) + = do newArgs <- getNewVars r + return (newArgs, addRs rs) + where + getNewVars [] = return [] + getNewVars ((PV n) : ns) = do nsv <- getNewVars ns + return (n : nsv) + getNewVars (_ : ns) = do v <- getVar + nsv <- getNewVars ns + return (v : nsv) + addRs [] = [] + addRs ((r, (ps, res)) : rs) = ((r++ps, res) : addRs rs) + +getVar :: State CS Name +getVar = do v <- get; put (v+1); return (MN v "e") + +groupCons :: [Clause] -> State CS [Group] +groupCons cs = gc [] cs + where + gc acc [] = return acc + gc acc ((p : ps, res) : cs) = + do acc' <- addGroup p ps res acc + gc acc' cs + addGroup p ps res acc = case p of + PCon con i args -> return $ addg con i args (ps, res) acc + PConst cval -> return $ addConG cval (ps, res) acc + pat -> fail $ show pat ++ " is not a constructor or constant (can't happen)" + + addg con i conargs res [] = [ConGroup (CName con i) [(conargs, res)]] + addg con i conargs res (g@(ConGroup (CName n j) cs):gs) + | i == j = ConGroup (CName n i) (cs ++ [(conargs, res)]) : gs + | otherwise = g : addg con i conargs res gs + + addConG con res [] = [ConGroup (CConst con) [([], res)]] + addConG con res (g@(ConGroup (CConst n) cs) : gs) + | con == n = ConGroup (CConst n) (cs ++ [([], res)]) : gs + | otherwise = g : addConG con res gs + +varRule :: [Name] -> [Clause] -> SC -> State CS SC +varRule (v : vs) alts err = + do let alts' = map (repVar v) alts + match vs alts' err + where + repVar v (PV p : ps , res) = (ps, subst p (P Bound v (V 0)) res) + repVar v (PAny : ps , res) = (ps, res) + +prune :: SC -> SC +prune (Case n alts) + = let alts' = map pruneAlt $ + filter notErased alts in + case alts' of + [] -> STerm Erased + as -> Case n as + where pruneAlt (ConCase n i ns sc) = ConCase n i ns (prune sc) + pruneAlt (ConstCase c sc) = ConstCase c (prune sc) + pruneAlt (DefaultCase sc) = DefaultCase (prune sc) + + notErased (DefaultCase (STerm Erased)) = False + notErased _ = True +prune t = t + + diff --git a/src/Core/Constraints.hs b/src/Core/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Core/Constraints.hs @@ -0,0 +1,52 @@ +module Core.Constraints(ucheck) where + +import Core.TT + +import Control.Applicative +import Control.Arrow +import Control.Monad.Error +import Control.Monad.RWS +import Control.Monad.State +import Data.List +import Data.Maybe +import qualified Data.Map as M + + +ucheck :: [(UConstraint, FC)] -> TC () +ucheck cs = acyclic rels (map fst (M.toList rels)) + where lhs (ULT l _) = l + lhs (ULE l _) = l + rels = mkRels cs M.empty + +type Relations = M.Map UExp [(UConstraint, FC)] + +mkRels :: [(UConstraint, FC)] -> Relations -> Relations +mkRels [] acc = acc +mkRels ((c, f) : cs) acc + = case M.lookup (lhs c) acc of + Nothing -> mkRels cs (M.insert (lhs c) [(c,f)] acc) + Just rs -> mkRels cs (M.insert (lhs c) ((c,f):rs) acc) + where lhs (ULT l _) = l + lhs (ULE l _) = l + +acyclic :: Relations -> [UExp] -> TC () +acyclic r cvs = checkCycle (FC "root" 0) r [] 0 cvs + where + checkCycle :: FC -> Relations -> [UExp] -> Int -> [UExp] -> TC () + checkCycle fc r path inc [] = return () + checkCycle fc r path inc (c : cs) + = do check fc path inc c + -- Remove c from r since we know there's no cycles now + let r' = M.insert c [] r + checkCycle fc r' path inc cs + + check fc path inc (UVar x) | x < 0 = return () + check fc path inc cv + | inc > 0 && cv `elem` path = Error $ At fc UniverseError + | otherwise = case M.lookup cv r of + Nothing -> return () + Just cs -> mapM_ (next (cv:path) inc) cs + + next path inc (ULT l r, fc) = check fc path (inc + 1) r + next path inc (ULE l r, fc) = check fc path inc r + diff --git a/src/Core/CoreParser.hs b/src/Core/CoreParser.hs new file mode 100644 --- /dev/null +++ b/src/Core/CoreParser.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +module Core.CoreParser(parseTerm, parseFile, parseDef, pTerm, iName, idrisDef) where + +import Core.TT + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as PTok + +import Control.Monad.State +import Debug.Trace + +type TokenParser a = PTok.TokenParser a + +idrisDef = haskellDef { + opStart = iOpStart, + opLetter = iOpLetter, + identLetter = identLetter haskellDef <|> lchar '.', + reservedOpNames = [":", "..", "=", "\\", "|", "<-", "->", "=>", "**"], + reservedNames = ["let", "in", "data", "Set", + "do", "dsl", "import", "impossible", + "case", "of", + "infix", "infixl", "infixr", "prefix", + "where", "with", "forall", "syntax", "proof", + "using", "params", "namespace", "class", "instance", + "public", "private", "abstract", + "Int", "Integer", "Float", "Char", "String", "Ptr"] + } + +iOpStart = oneOf ":!#$%&*+./<=>?@\\^|-~" +iOpLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" +-- <|> letter + +lexer :: TokenParser a +lexer = PTok.makeTokenParser idrisDef + +whiteSpace= PTok.whiteSpace lexer +lexeme = PTok.lexeme lexer +symbol = PTok.symbol lexer +natural = PTok.natural lexer +parens = PTok.parens lexer +semi = PTok.semi lexer +comma = PTok.comma lexer +identifier= PTok.identifier lexer +reserved = PTok.reserved lexer +operator = PTok.operator lexer +reservedOp= PTok.reservedOp lexer +lchar = lexeme.char + +type CParser a = GenParser Char a + +parseFile = runParser pTestFile () "(input)" +parseDef = runParser pDef () "(input)" +parseTerm = runParser pTerm () "(input)" + +pTestFile :: CParser a RProgram +pTestFile = do p <- many1 pDef ; eof + return p + +iName :: [String] -> CParser a Name +iName bad = do x <- identifier + when (x `elem` bad) $ fail "Reserved identifier" + return $ mkNS (reverse (parseName x)) + where + mkNS [x] = UN x + mkNS (x:xs) = NS (UN x) xs + parseName x = case span (/= '.') x of + (x, "") -> [x] + (x, '.':y) -> x : parseName y + +pDef :: CParser a (Name, RDef) +pDef = try (do x <- iName []; lchar ':'; ty <- pTerm + lchar '=' + tm <- pTerm + lchar ';' + return (x, RFunction (RawFun ty tm))) + <|> do x <- iName []; lchar ':'; ty <- pTerm; lchar ';' + return (x, RConst ty) + <|> do (x, d) <- pData; lchar ';' + return (x, RData d) + +app :: CParser a (Raw -> Raw -> Raw) +app = do whiteSpace ; return RApp + +arrow :: CParser a (Raw -> Raw -> Raw) +arrow = do symbol "->" ; return $ \s t -> RBind (MN 0 "X") (Pi s) t + +pTerm :: CParser a Raw +pTerm = try (do chainl1 pNoApp app) + <|> pNoApp + +pNoApp :: CParser a Raw +pNoApp = try (chainr1 pExp arrow) + <|> pExp +pExp :: CParser a Raw +pExp = do lchar '\\'; x <- iName []; lchar ':'; ty <- pTerm + symbol "=>"; + sc <- pTerm + return (RBind x (Lam ty) sc) + <|> try (do lchar '?'; x <- iName []; lchar ':'; ty <- pTerm + lchar '.'; + sc <- pTerm + return (RBind x (Hole ty) sc)) + <|> try (do lchar '('; + x <- iName []; lchar ':'; ty <- pTerm + lchar ')'; + symbol "->"; + sc <- pTerm + return (RBind x (Pi ty) sc)) + <|> try (do lchar '('; + t <- pTerm + lchar ')' + return t) + <|> try (do symbol "??"; + x <- iName []; lchar ':'; ty <- pTerm + lchar '='; + val <- pTerm + sc <- pTerm + return (RBind x (Guess ty val) sc)) + <|> try (do reserved "let"; + x <- iName []; lchar ':'; ty <- pTerm + lchar '='; + val <- pTerm + reserved "in"; + sc <- pTerm + return (RBind x (Let ty val) sc)) + <|> try (do lchar '_'; + x <- iName []; lchar ':'; ty <- pTerm + lchar '.'; + sc <- pTerm + return (RBind x (PVar ty) sc)) + <|> try (do reserved "Set" + return RSet) + <|> try (do x <- iName [] + return (Var x)) + +pData :: CParser a (Name, RawDatatype) +pData = do reserved "data"; x <- iName []; lchar ':'; ty <- pTerm; reserved "where" + cs <- many pConstructor + return (x, RDatatype x ty cs) + +pConstructor :: CParser a (Name, Raw) +pConstructor = do lchar '|' + c <- iName []; lchar ':'; ty <- pTerm + return (c, ty) + diff --git a/src/Core/Elaborate.hs b/src/Core/Elaborate.hs new file mode 100644 --- /dev/null +++ b/src/Core/Elaborate.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-} + +{- A high level language of tactic composition, for building + elaborators from a high level language into the core theory. + + This is our interface to proof construction, rather than + ProofState, because this gives us a language to build derived + tactics out of the primitives. +-} + +module Core.Elaborate(module Core.Elaborate, + module Core.ProofState) where + +import Core.ProofState +import Core.TT +import Core.Evaluate +import Core.Typecheck + +import Control.Monad.State +import Data.Char +import Data.List +import Debug.Trace + +-- I don't really want this here, but it's useful for the test shell +data Command = Theorem Name Raw + | Eval Raw + | Quit + | Print Name + | Tac (Elab ()) + +data ElabState aux = ES (ProofState, aux) String (Maybe (ElabState aux)) + deriving Show +type Elab' aux a = StateT (ElabState aux) TC a +type Elab a = Elab' () a + +proof :: ElabState aux -> ProofState +proof (ES (p, _) _ _) = p + +saveState :: Elab' aux () +saveState = do e@(ES p s _) <- get + put (ES p s (Just e)) + +loadState :: Elab' aux () +loadState = do (ES p s e) <- get + case e of + Just st -> put st + _ -> fail "Nothing to undo" + +erun :: FC -> Elab' aux a -> Elab' aux a +erun f elab = do s <- get + case runStateT elab s of + OK (a, s') -> do put s' + return a + Error (At f e) -> lift $ Error (At f e) + Error e -> lift $ Error (At f e) + +runElab :: aux -> Elab' aux a -> ProofState -> TC (a, ElabState aux) +runElab a e ps = runStateT e (ES (ps, a) "" Nothing) + +execElab :: aux -> Elab' aux a -> ProofState -> TC (ElabState aux) +execElab a e ps = execStateT e (ES (ps, a) "" Nothing) + +initElaborator :: Name -> Context -> Type -> ProofState +initElaborator = newProof + +elaborate :: Context -> Name -> Type -> aux -> Elab' aux a -> TC (a, String) +elaborate ctxt n ty d elab = do let ps = initElaborator n ctxt ty + (a, ES ps' str _) <- runElab d elab ps + return (a, str) + +updateAux :: (aux -> aux) -> Elab' aux () +updateAux f = do ES (ps, a) l p <- get + put (ES (ps, f a) l p) + +getAux :: Elab' aux aux +getAux = do ES (ps, a) _ _ <- get + return a + +processTactic' t = do ES (p, a) logs prev <- get + (p', log) <- lift $ processTactic t p + put (ES (p', a) (logs ++ log) prev) + return () + +-- Some handy gadgets for pulling out bits of state + +-- get the global context +get_context :: Elab' aux Context +get_context = do ES p _ _ <- get + return (context (fst p)) + +-- get the proof term +get_term :: Elab' aux Term +get_term = do ES p _ _ <- get + return (pterm (fst p)) + +-- get the local context at the currently in focus hole +get_env :: Elab' aux Env +get_env = do ES p _ _ <- get + lift $ envAtFocus (fst p) + +get_holes :: Elab' aux [Name] +get_holes = do ES p _ _ <- get + return (holes (fst p)) + +-- get the current goal type +goal :: Elab' aux Type +goal = do ES p _ _ <- get + b <- lift $ goalAtFocus (fst p) + return (binderTy b) + +-- typecheck locally +get_type :: Raw -> Elab' aux Type +get_type tm = do ctxt <- get_context + env <- get_env + (val, ty) <- lift $ check ctxt env tm + return (finalise ty) + +-- get holes we've deferred for later definition +get_deferred :: Elab' aux [Name] +get_deferred = do ES p _ _ <- get + return (deferred (fst p)) + +get_inj :: Elab' aux [(Term, Term, Term)] +get_inj = do ES p _ _ <- get + return (injective (fst p)) + +checkInjective :: (Term, Term, Term) -> Elab' aux () +checkInjective (tm, l, r) = if isInjective tm then return () + else lift $ tfail (NotInjective tm l r) + +-- get instance argument names +get_instances :: Elab' aux [Name] +get_instances = do ES p _ _ <- get + return (instances (fst p)) + +-- given a desired hole name, return a unique hole name +unique_hole :: Name -> Elab' aux Name +unique_hole n = do ES p _ _ <- get + let bs = bound_in (pterm (fst p)) ++ bound_in (ptype (fst p)) + n' <- uniqueNameCtxt (context (fst p)) n (holes (fst p) ++ bs) + return n' + where + bound_in (Bind n b sc) = n : bi b ++ bound_in sc + where + bi (Let t v) = bound_in t ++ bound_in v + bi (Guess t v) = bound_in t ++ bound_in v + bi b = bound_in (binderTy b) + bound_in (App f a) = bound_in f ++ bound_in a + bound_in _ = [] + +uniqueNameCtxt :: Context -> Name -> [Name] -> Elab' aux Name +uniqueNameCtxt ctxt n hs + | n `elem` hs = uniqueNameCtxt ctxt (nextName n) hs + | [_] <- lookupTy Nothing n ctxt = uniqueNameCtxt ctxt (nextName n) hs + | otherwise = return n + +elog :: String -> Elab' aux () +elog str = do ES p logs prev <- get + put (ES p (logs ++ str ++ "\n") prev) + +-- The primitives, from ProofState + +attack :: Elab' aux () +attack = processTactic' Attack + +claim :: Name -> Raw -> Elab' aux () +claim n t = processTactic' (Claim n t) + +exact :: Raw -> Elab' aux () +exact t = processTactic' (Exact t) + +fill :: Raw -> Elab' aux () +fill t = processTactic' (Fill t) + +prep_fill :: Name -> [Name] -> Elab' aux () +prep_fill n ns = processTactic' (PrepFill n ns) + +complete_fill :: Elab' aux () +complete_fill = processTactic' CompleteFill + +solve :: Elab' aux () +solve = processTactic' Solve + +start_unify :: Name -> Elab' aux () +start_unify n = processTactic' (StartUnify n) + +end_unify :: Elab' aux () +end_unify = processTactic' EndUnify + +regret :: Elab' aux () +regret = processTactic' Regret + +compute :: Elab' aux () +compute = processTactic' Compute + +eval_in :: Raw -> Elab' aux () +eval_in t = processTactic' (EvalIn t) + +check_in :: Raw -> Elab' aux () +check_in t = processTactic' (CheckIn t) + +intro :: Maybe Name -> Elab' aux () +intro n = processTactic' (Intro n) + +introTy :: Raw -> Maybe Name -> Elab' aux () +introTy ty n = processTactic' (IntroTy ty n) + +forall :: Name -> Raw -> Elab' aux () +forall n t = processTactic' (Forall n t) + +letbind :: Name -> Raw -> Raw -> Elab' aux () +letbind n t v = processTactic' (LetBind n t v) + +rewrite :: Raw -> Elab' aux () +rewrite tm = processTactic' (Rewrite tm) + +patvar :: Name -> Elab' aux () +patvar n = do env <- get_env + if (n `elem` map fst env) then do apply (Var n) []; solve + else do n' <- case n of + UN _ -> return n + MN _ _ -> unique_hole n + NS _ _ -> return n + processTactic' (PatVar n') + +patbind :: Name -> Elab' aux () +patbind n = processTactic' (PatBind n) + +focus :: Name -> Elab' aux () +focus n = processTactic' (Focus n) + +movelast :: Name -> Elab' aux () +movelast n = processTactic' (MoveLast n) + +defer :: Name -> Elab' aux () +defer n = do n' <- unique_hole n + processTactic' (Defer n') + +instanceArg :: Name -> Elab' aux () +instanceArg n = processTactic' (Instance n) + +proofstate :: Elab' aux () +proofstate = processTactic' ProofState + +reorder_claims :: Name -> Elab' aux () +reorder_claims n = processTactic' (Reorder n) + +qed :: Elab' aux Term +qed = do processTactic' QED + ES p _ _ <- get + return (pterm (fst p)) + +undo :: Elab' aux () +undo = processTactic' Undo + +prepare_apply :: Raw -> [Bool] -> Elab' aux [Name] +prepare_apply fn imps = + do ty <- get_type fn + ctxt <- get_context + env <- get_env + -- let claims = getArgs ty imps + claims <- mkClaims (normalise ctxt env ty) imps [] + ES (p, a) s prev <- get + -- reverse the claims we made so that args go left to right + let n = length (filter not imps) + let (h : hs) = holes p + put (ES (p { holes = h : (reverse (take n hs) ++ drop n hs) }, a) s prev) +-- case claims of +-- [] -> return () +-- (h : _) -> reorder_claims h + return claims + where + mkClaims (Bind n' (Pi t) sc) (i : is) claims = + do n <- unique_hole (mkMN n') +-- when (null claims) (start_unify n) + let sc' = instantiate (P Bound n t) sc + claim n (forget t) + when i (movelast n) + mkClaims sc' is (n : claims) + mkClaims t [] claims = return (reverse claims) + mkClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show fn + + doClaim ((i, _), n, t) = do claim n t + when i (movelast n) + + mkMN n@(MN _ _) = n + mkMN n@(UN x) = MN 0 x + mkMN (NS n xs) = NS (mkMN n) xs + +apply :: Raw -> [(Bool, Int)] -> Elab' aux [Name] +apply fn imps = + do args <- prepare_apply fn (map fst imps) + fill (raw_apply fn (map Var args)) + -- *Don't* solve the arguments we're specifying by hand. + -- (remove from unified list before calling end_unify) + -- HMMM: Actually, if we get it wrong, the typechecker will complain! + -- so do nothing + ptm <- get_term + let dontunify = [] -- map fst (filter (not.snd) (zip args (map fst imps))) + ES (p, a) s prev <- get + let (n, hs) = unified p + let unify = (n, filter (\ (n, t) -> not (n `elem` dontunify)) hs) + put (ES (p { unified = unify }, a) s prev) + end_unify + return (map (updateUnify hs) args) + where updateUnify hs n = case lookup n hs of + Just (P _ t _) -> t + _ -> n + +apply2 :: Raw -> [Maybe (Elab' aux ())] -> Elab' aux () +apply2 fn elabs = + do args <- prepare_apply fn (map isJust elabs) + fill (raw_apply fn (map Var args)) + elabArgs args elabs + ES (p, a) s prev <- get + let (n, hs) = unified p + end_unify + solve + where elabArgs [] [] = return () + elabArgs (n:ns) (Just e:es) = do focus n; e + elabArgs ns es + elabArgs (n:ns) (_:es) = elabArgs ns es + + isJust (Just _) = False + isJust _ = True + +apply_elab :: Name -> [Maybe (Int, Elab' aux ())] -> Elab' aux () +apply_elab n args = + do ty <- get_type (Var n) + ctxt <- get_context + env <- get_env + claims <- doClaims (normalise ctxt env ty) args [] + prep_fill n (map fst claims) + let eclaims = sortBy (\ (_, x) (_,y) -> priOrder x y) claims + elabClaims [] False claims + complete_fill + end_unify + where + priOrder Nothing Nothing = EQ + priOrder Nothing _ = LT + priOrder _ Nothing = GT + priOrder (Just (x, _)) (Just (y, _)) = compare x y + + doClaims (Bind n' (Pi t) sc) (i : is) claims = + do n <- unique_hole (mkMN n') + when (null claims) (start_unify n) + let sc' = instantiate (P Bound n t) sc + claim n (forget t) + doClaims sc' is ((n, i) : claims) + doClaims t [] claims = return (reverse claims) + doClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show n + + elabClaims failed r [] + | null failed = return () + | otherwise = if r then elabClaims [] False failed + else return () + elabClaims failed r ((n, Nothing) : xs) = elabClaims failed r xs + elabClaims failed r (e@(n, Just (_, elaboration)) : xs) + | r = try (do ES p _ _ <- get + focus n; elaboration; elabClaims failed r xs) + (elabClaims (e : failed) r xs) + | otherwise = do ES p _ _ <- get + focus n; elaboration; elabClaims failed r xs + + mkMN n@(MN _ _) = n + mkMN n@(UN x) = MN 0 x + mkMN (NS n ns) = NS (mkMN n) ns + +simple_app :: Elab' aux () -> Elab' aux () -> Elab' aux () +simple_app fun arg = + do a <- unique_hole (MN 0 "a") + b <- unique_hole (MN 0 "b") + f <- unique_hole (MN 0 "f") + s <- unique_hole (MN 0 "s") + claim a RSet + claim b RSet + claim f (RBind (MN 0 "aX") (Pi (Var a)) (Var b)) + start_unify s + claim s (Var a) + prep_fill f [s] + -- try elaborating in both orders, since we might learn something useful + -- either way + try (do focus s; arg + focus f; fun) + (do focus f; fun + focus s; arg) + complete_fill + end_unify + +-- Abstract over an argument of unknown type, giving a name for the hole +-- which we'll fill with the argument type too. +arg :: Name -> Name -> Elab' aux () +arg n tyhole = do ty <- unique_hole tyhole + claim ty RSet + forall n (Var ty) + +-- Try a tactic, if it fails, try another +try :: Elab' aux a -> Elab' aux a -> Elab' aux a +try t1 t2 = do s <- get + case runStateT t1 s of + OK (v, s') -> do put s' + return v + Error e1 -> do put s + case runStateT t2 s of + OK (v, s') -> do put s'; return v + Error e2 -> if score e1 > score e2 + then lift (tfail e1) + else lift (tfail e2) + +-- Try a selection of tactics. Exactly one must work, all others must fail +tryAll :: [(Elab' aux a, String)] -> Elab' aux a +tryAll xs = tryAll' [] (cantResolve, 0) (map fst xs) + where + cantResolve :: Elab' aux a + cantResolve = fail $ "Couldn't resolve alternative: " + ++ showSep ", " (map snd xs) + + tryAll' :: [Elab' aux a] -> -- successes + (Elab' aux a, Int) -> -- smallest failure + [Elab' aux a] -> -- still to try + Elab' aux a + tryAll' [res] _ [] = res + tryAll' (_:_) _ [] = cantResolve + tryAll' [] (f, _) [] = f + tryAll' cs f (x:xs) = do s <- get + case runStateT x s of + OK (v, s') -> tryAll' ((do put s' + return v):cs) f xs + Error err -> do put s + tryAll' cs (better err f) xs + + better err (f, i) = let s = score err in + if (s >= i) then (lift (tfail err), s) + else (f, i) + diff --git a/src/Core/Evaluate.hs b/src/Core/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/Core/Evaluate.hs @@ -0,0 +1,596 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, + PatternGuards #-} + +module Core.Evaluate(normalise, normaliseC, normaliseAll, + simplify, specialise, hnf, + Def(..), Accessibility(..), + Context, initContext, ctxtAlist, uconstraints, next_tvar, + addToCtxt, setAccess, addCtxtDef, addTyDecl, addDatatype, + addCasedef, addOperator, + lookupTy, lookupP, lookupDef, lookupVal, lookupTyEnv, isConName, + Value(..)) where + +import Debug.Trace +import Control.Monad.State +import qualified Data.Binary as B +import Data.Binary hiding (get, put) + +import Core.TT +import Core.CaseTree + +type EvalState = () +type Eval a = State EvalState a + +data EvalOpt = Spec | HNF | Simplify | AtREPL + deriving (Show, Eq) + +-- VALUES (as HOAS) --------------------------------------------------------- + +data Value = VP NameType Name Value + | VV Int + | VBind Name (Binder Value) (Value -> Eval Value) + | VApp Value Value + | VSet UExp + | VErased + | VConstant Const + | VTmp Int + +data HNF = HP NameType Name (TT Name) + | HV Int + | HBind Name (Binder HNF) (HNF -> Eval HNF) + | HApp HNF [HNF] [TT Name] + | HSet UExp + | HConstant Const + | HTmp Int + deriving Show + +instance Show Value where + show x = show $ evalState (quote 10 x) () + +instance Show (a -> b) where + show x = "<>" + +-- THE EVALUATOR ------------------------------------------------------------ + +-- The environment is assumed to be "locally named" - i.e., not de Bruijn +-- indexed. +-- i.e. it's an intermediate environment that we have while type checking or +-- while building a proof. + +normaliseC :: Context -> Env -> TT Name -> TT Name +normaliseC ctxt env t + = evalState (do val <- eval ctxt emptyContext env t [] + quote 0 val) () + +normaliseAll :: Context -> Env -> TT Name -> TT Name +normaliseAll ctxt env t + = evalState (do val <- eval ctxt emptyContext env t [AtREPL] + quote 0 val) () + +normalise :: Context -> Env -> TT Name -> TT Name +normalise ctxt env t + = evalState (do val <- eval ctxt emptyContext (map finalEntry env) (finalise t) [] + quote 0 val) () + +specialise :: Context -> Ctxt [Bool] -> TT Name -> TT Name +specialise ctxt statics t + = evalState (do val <- eval ctxt statics [] (finalise t) [Spec] + quote 0 val) () + +-- Like normalise, but we only reduce functions that are marked as okay to +-- inline (and probably shouldn't reduce lets?) + +simplify :: Context -> Env -> TT Name -> TT Name +simplify ctxt env t + = evalState (do val <- eval ctxt emptyContext (map finalEntry env) (finalise t) [Simplify] + quote 0 val) () + +hnf :: Context -> Env -> TT Name -> TT Name +hnf ctxt env t + = evalState (do val <- eval ctxt emptyContext (map finalEntry env) (finalise t) [HNF] + quote 0 val) () + + +-- unbindEnv env (quote 0 (eval ctxt (bindEnv env t))) + +finalEntry :: (Name, Binder (TT Name)) -> (Name, Binder (TT Name)) +finalEntry (n, b) = (n, fmap finalise b) + +bindEnv :: EnvTT n -> TT n -> TT n +bindEnv [] tm = tm +bindEnv ((n, Let t v):bs) tm = Bind n (NLet t v) (bindEnv bs tm) +bindEnv ((n, b):bs) tm = Bind n b (bindEnv bs tm) + +unbindEnv :: EnvTT n -> TT n -> TT n +unbindEnv [] tm = tm +unbindEnv (_:bs) (Bind n b sc) = unbindEnv bs sc + +-- Evaluate in a context of locally named things (i.e. not de Bruijn indexed, +-- such as we might have during construction of a proof) + +eval :: Context -> Ctxt [Bool] -> Env -> TT Name -> [EvalOpt] -> Eval Value +eval ctxt statics genv tm opts = ev [] True [] tm where + spec = Spec `elem` opts + simpl = Simplify `elem` opts + atRepl = AtREPL `elem` opts + + ev stk top env (P _ n ty) + | Just (Let t v) <- lookup n genv = ev stk top env v + ev stk top env (P Ref n ty) = case lookupDefAcc Nothing n atRepl ctxt of + [(Function _ tm, Public)] -> + ev (n:stk) True env tm + [(TyDecl nt ty, _)] -> do vty <- ev stk True env ty + return $ VP nt n vty + [(CaseOp inl _ _ [] tree _ _, Public)] -> -- unoptimised version + if simpl && (not inl || elem n stk) + then liftM (VP Ref n) (ev stk top env ty) + else do c <- evCase (n:stk) top env [] [] tree + case c of + (Nothing, _) -> liftM (VP Ref n) (ev stk top env ty) + (Just v, _) -> return v + _ -> liftM (VP Ref n) (ev stk top env ty) + ev stk top env (P nt n ty) = liftM (VP nt n) (ev stk top env ty) + ev stk top env (V i) | i < length env = return $ env !! i + | otherwise = return $ VV i + ev stk top env (Bind n (Let t v) sc) + = do v' <- ev stk top env v --(finalise v) + sc' <- ev stk top (v' : env) sc + wknV (-1) sc' + ev stk top env (Bind n (NLet t v) sc) + = do t' <- ev stk top env (finalise t) + v' <- ev stk top env (finalise v) + sc' <- ev stk top (v' : env) sc + return $ VBind n (Let t' v') (\x -> return sc') + ev stk top env (Bind n b sc) + = do b' <- vbind env b + return $ VBind n b' (\x -> ev stk top (x:env) sc) + where vbind env t = fmapMB (\tm -> ev stk top env (finalise tm)) t + ev stk top env (App f a) = do f' <- ev stk top env f + a' <- ev stk False env a + evApply stk top env [a'] f' + ev stk top env (Constant c) = return $ VConstant c + ev stk top env Erased = return VErased + ev stk top env (Set i) = return $ VSet i + + evApply stk top env args (VApp f a) = + evApply stk top env (a:args) f + evApply stk top env args f = apply stk top env f args + + apply stk top env (VBind n (Lam t) sc) (a:as) + = do a' <- sc a + app <- apply stk top env a' as + wknV (-1) app + apply stk False env f args + | spec = return $ unload env f args + apply stk top env (VP Ref n ty) args + | [(CaseOp inl _ _ ns tree _ _, Public)] <- lookupDefAcc Nothing n atRepl ctxt + = -- traceWhen (n == UN ["interp"]) (show (n, args)) $ + if simpl && (not inl || elem n stk) + then return $ unload env (VP Ref n ty) args + else do c <- evCase (n:stk) top env ns args tree + case c of + (Nothing, _) -> return $ unload env (VP Ref n ty) args + (Just v, rest) -> evApply stk top env rest v + | [Operator _ i op] <- lookupDef Nothing n ctxt + = if (i <= length args) + then case op (take i args) of + Nothing -> return $ unload env (VP Ref n ty) args + Just v -> evApply stk top env (drop i args) v + else return $ unload env (VP Ref n ty) args + apply stk top env f (a:as) = return $ unload env f (a:as) + apply stk top env f [] = return f + + unload env f [] = f + unload env f (a:as) = unload env (VApp f a) as + + evCase stk top env ns args tree + | length ns <= length args + = do let args' = take (length ns) args + let rest = drop (length ns) args + t <- evTree stk top env (zipWith (\n t -> (n, t)) ns args') tree + return (t, rest) + | otherwise = return (Nothing, args) + + evTree :: [Name] -> Bool -> [Value] -> [(Name, Value)] -> SC -> Eval (Maybe Value) + evTree stk top env amap (UnmatchedCase str) = return Nothing + evTree stk top env amap (STerm tm) + = do let etm = pToVs (map fst amap) tm + etm' <- ev stk top (map snd amap ++ env) etm + return $ Just etm' + evTree stk top env amap (Case n alts) + = case lookup n amap of + Just v -> do c <- chooseAlt env v (getValArgs v) alts amap + case c of + Just (altmap, sc) -> evTree stk top env altmap sc + _ -> do c' <- chooseAlt' stk env v (getValArgs v) alts amap + case c' of + Just (altmap, sc) -> evTree stk top env altmap sc + _ -> return Nothing + _ -> return Nothing + + chooseAlt' stk env _ (f, args) alts amap + = do f' <- apply stk True env f args + chooseAlt env f' (getValArgs f') alts amap + + chooseAlt :: [Value] -> Value -> (Value, [Value]) -> [CaseAlt] -> [(Name, Value)] -> + Eval (Maybe ([(Name, Value)], SC)) + chooseAlt env _ (VP (DCon i a) _ _, args) alts amap + | Just (ns, sc) <- findTag i alts = return $ Just (updateAmap (zip ns args) amap, sc) + | Just v <- findDefault alts = return $ Just (amap, v) + chooseAlt env _ (VP (TCon i a) _ _, args) alts amap + | Just (ns, sc) <- findTag i alts = return $ Just (updateAmap (zip ns args) amap, sc) + | Just v <- findDefault alts = return $ Just (amap, v) + chooseAlt env _ (VConstant c, []) alts amap + | Just v <- findConst c alts = return $ Just (amap, v) + | Just v <- findDefault alts = return $ Just (amap, v) + chooseAlt _ _ _ _ _ = return Nothing + + -- Replace old variable names in the map with new matches + -- (This is possibly unnecessary since we make unique names and don't + -- allow repeated variables...?) + updateAmap newm amap + = newm ++ filter (\ (x, _) -> not (elem x (map fst newm))) amap + findTag i [] = Nothing + findTag i (ConCase n j ns sc : xs) | i == j = Just (ns, sc) + findTag i (_ : xs) = findTag i xs + + findDefault [] = Nothing + findDefault (DefaultCase sc : xs) = Just sc + findDefault (_ : xs) = findDefault xs + + findConst c [] = Nothing + findConst c (ConstCase c' v : xs) | c == c' = Just v + findConst IType (ConCase n 1 [] v : xs) = Just v + findConst FlType (ConCase n 2 [] v : xs) = Just v + findConst ChType (ConCase n 3 [] v : xs) = Just v + findConst StrType (ConCase n 4 [] v : xs) = Just v + findConst PtrType (ConCase n 5 [] v : xs) = Just v + findConst c (_ : xs) = findConst c xs + + getValArgs tm = getValArgs' tm [] + getValArgs' (VApp f a) as = getValArgs' f (a:as) + getValArgs' f as = (f, as) + +class Quote a where + quote :: Int -> a -> Eval (TT Name) + +instance Quote Value where + quote i (VP nt n v) = liftM (P nt n) (quote i v) + quote i (VV x) = return $ V x + quote i (VBind n b sc) = do sc' <- sc (VTmp i) + b' <- quoteB b + liftM (Bind n b') (quote (i+1) sc') + where quoteB t = fmapMB (quote i) t + quote i (VApp f a) = liftM2 App (quote i f) (quote i a) + quote i (VSet u) = return $ Set u + quote i VErased = return $ Erased + quote i (VConstant c) = return $ Constant c + quote i (VTmp x) = return $ V (i - x - 1) + +instance Quote HNF where + quote i (HP nt n t) = return (P nt n t) + quote i (HV x) = return $ V x + quote i (HBind n b sc) = do sc' <- sc (HTmp i) + b' <- quoteB b + liftM (Bind n b') (quote (i+1) sc') + where quoteB t = fmapMB (quote i) t + quote i (HApp f env as) = do f' <- quote i f + as' <- mapM (iEnv env) as + return $ mkApp f' as' + where iEnv [] a = return a + iEnv (x:xs) a = do x' <- quote i x + iEnv xs (weakenTm (-1) (instantiate x' a)) + quote i (HSet u) = return $ Set u + quote i (HConstant c) = return $ Constant c + quote i (HTmp x) = return $ V (i - x - 1) + +wknV :: Int -> Value -> Eval Value +wknV i (VV x) = return $ VV (x + i) +wknV i (VBind n b sc) = do b' <- fmapMB (wknV i) b + return $ VBind n b' (\x -> do x' <- sc x + wknV i x') +wknV i (VApp f a) = liftM2 VApp (wknV i f) (wknV i a) +wknV i t = return t + +wknH :: Int -> HNF -> Eval HNF +wknH i (HV x) = return $ HV (x + i) +wknH i (HBind n b sc) = do b' <- fmapMB (wknH i) b + return $ HBind n b' (\x -> do x' <- sc x + wknH i x') +wknH i (HApp f env as) = liftM3 HApp (wknH i f) (return env) + (return as) +wknH i t = return t + +-- HEAD NORMAL FORM --------------------------------------------------------- + +eval_hnf :: Context -> Ctxt [Bool] -> Env -> TT Name -> Eval HNF +eval_hnf ctxt statics genv tm = ev [] tm where + ev :: [HNF] -> TT Name -> Eval HNF + ev env (P _ n ty) + | Just (Let t v) <- lookup n genv = ev env v + ev env (P Ref n ty) = case lookupDef Nothing n ctxt of + [Function _ t] -> ev env t + [TyDecl nt ty] -> return $ HP nt n ty + [CaseOp inl _ _ [] tree _ _] -> + do c <- evCase env [] [] tree + case c of + (Nothing, _, _) -> return $ HP Ref n ty + (Just v, _, _) -> return v + _ -> return $ HP Ref n ty + ev env (P nt n ty) = return $ HP nt n ty + ev env (V i) | i < length env = return $ env !! i + | otherwise = return $ HV i + ev env (Bind n (Let t v) sc) + = do v' <- ev env (finalise v) + sc' <- ev (v' : env) sc + wknH (-1) sc' + ev env (Bind n b sc) + = do b' <- hbind env b + return $ HBind n b' (\x -> ev (x : env) sc) + where hbind env t = fmapMB (\tm -> ev env (finalise tm)) t + ev env (App f a) = evApply env [a] f + ev env (Constant c) = return $ HConstant c + ev env (Set i) = return $ HSet i + + evApply env args (App f a) = evApply env (a : args) f + evApply env args f = do f' <- ev env f + apply env f' args + + apply env (HBind n (Lam t) sc) (a:as) = do a' <- ev env a + sc' <- sc a' + app <- apply env sc' as + wknH (-1) app + apply env (HP Ref n ty) args + | [CaseOp _ _ _ ns tree _ _] <- lookupDef Nothing n ctxt + = do c <- evCase env ns args tree + case c of + (Nothing, _, env') -> return $ unload env' (HP Ref n ty) args + (Just v, rest, env') -> do v' <- quote 0 v + apply env' v rest +-- | Just (Operator _ i op) <- lookupDef n ctxt +-- = if (i <= length args) +-- then case op (take i args) of +-- Nothing -> return $ unload env (HP Ref n ty) args +-- Just v -> evApply env (drop i args) v +-- else return $ unload env (HP Ref n ty) args + apply env f (a:as) = return $ unload env f (a:as) + apply env f [] = return f + + unload env f [] = f + unload env f as = HApp f env as + + evCase env ns args tree + | length ns <= length args + = do let args' = take (length ns) args + let rest = drop (length ns) args + (t, env') <- evTree env (zipWith (\n t -> (n, t)) ns args') tree + return (t, rest, env') + | otherwise = return (Nothing, args, env) + + evTree :: [HNF] -> [(Name, TT Name)] -> SC -> Eval (Maybe HNF, [HNF]) + evTree env amap (UnmatchedCase str) = return (Nothing, env) + evTree env amap (STerm tm) + = do let etm = pToVs (map fst amap) tm + amap' <- mapM (ev env) (map snd amap) + envw <- mapM (wknH (length amap)) env + let env' = amap' ++ envw + etm' <- trace (show etm) $ ev env' etm + etmq <- quote 0 etm' + trace ("Ev: " ++ show (etm, etmq)) $ return $ (Just etm', env') + evTree env amap (Case n alts) + = case lookup n amap of + Just v -> do v' <- ev env v + case chooseAlt v' (getValArgs v') alts amap of + Just (altmap, sc) -> evTree env altmap sc + _ -> return (Nothing, env) + + chooseAlt :: HNF -> (HNF, [HNF], [TT Name]) -> + [CaseAlt] -> [(Name, TT Name)] -> + Maybe ([(Name, TT Name)], SC) + chooseAlt _ (HP (DCon i a) _ _, env, args) alts amap + | Just (ns, sc) <- findTag i alts = Just (updateAmap (zip ns args) amap, sc) + | Just v <- findDefault alts = Just (amap, v) + chooseAlt _ (HP (TCon i a) _ _, env, args) alts amap + | Just (ns, sc) <- findTag i alts = Just (updateAmap (zip ns args) amap, sc) + | Just v <- findDefault alts = Just (amap, v) + chooseAlt _ (HConstant c, env, []) alts amap + | Just v <- findConst c alts = Just (amap, v) + | Just v <- findDefault alts = Just (amap, v) + chooseAlt _ _ _ _ = Nothing + + -- Replace old variable names in the map with new matches + -- (This is possibly unnecessary since we make unique names and don't + -- allow repeated variables...?) + updateAmap newm amap + = newm ++ filter (\ (x, _) -> not (elem x (map fst newm))) amap + findTag i [] = Nothing + findTag i (ConCase n j ns sc : xs) | i == j = Just (ns, sc) + findTag i (_ : xs) = findTag i xs + + findDefault [] = Nothing + findDefault (DefaultCase sc : xs) = Just sc + findDefault (_ : xs) = findDefault xs + + findConst c [] = Nothing + findConst c (ConstCase c' v : xs) | c == c' = Just v + findConst IType (ConCase n 1 [] v : xs) = Just v + findConst FlType (ConCase n 2 [] v : xs) = Just v + findConst ChType (ConCase n 3 [] v : xs) = Just v + findConst StrType (ConCase n 4 [] v : xs) = Just v + findConst PtrType (ConCase n 5 [] v : xs) = Just v + findConst c (_ : xs) = findConst c xs + + getValArgs (HApp t env args) = (t, env, args) + getValArgs t = (t, [], []) + +-- SPECIALISATION ----------------------------------------------------------- +-- We need too much control to be able to do this by tweaking the main +-- evaluator + +spec :: Context -> Ctxt [Bool] -> Env -> TT Name -> Eval (TT Name) +spec ctxt statics genv tm = error "spec undefined" + +-- CONTEXTS ----------------------------------------------------------------- + +{- A definition is either a simple function (just an expression with a type), + a constant, which could be a data or type constructor, an axiom or as an + yet undefined function, or an Operator. + An Operator is a function which explains how to reduce. + A CaseOp is a function defined by a simple case tree -} + +data Def = Function Type Term + | TyDecl NameType Type + | Operator Type Int ([Value] -> Maybe Value) + | CaseOp Bool Type [(Term, Term)] -- Bool for inlineable + [Name] SC -- Compile time case definition + [Name] SC -- Run time cae definitions +{-! +deriving instance Binary Def +!-} + +instance Show Def where + show (Function ty tm) = "Function: " ++ show (ty, tm) + show (TyDecl nt ty) = "TyDecl: " ++ show nt ++ " " ++ show ty + show (Operator ty _ _) = "Operator: " ++ show ty + show (CaseOp _ ty ps ns sc ns' sc') + = "Case: " ++ show ty ++ " " ++ show ps ++ "\n" ++ + show ns ++ " " ++ show sc ++ "\n" ++ + show ns' ++ " " ++ show sc' +-- We need this for serialising Def. Fortunately, it never gets used because +-- we'll never serialise a primitive operator + +instance Binary (a -> b) where + put x = return () + get = error "Getting a function" + +------- + +-- Frozen => doesn't reduce +-- Hidden => doesn't reduce and invisible to type checker + +data Accessibility = Public | Frozen | Hidden + deriving (Show, Eq) +{-! +deriving instance Binary Accessibility +!-} + +data Context = MkContext { uconstraints :: [UConstraint], + next_tvar :: Int, + definitions :: Ctxt (Def, Accessibility) } + +initContext = MkContext [] 0 emptyContext + +ctxtAlist :: Context -> [(Name, Def)] +ctxtAlist ctxt = map (\(n, (d, a)) -> (n, d)) $ toAlist (definitions ctxt) + +veval ctxt env t = evalState (eval ctxt emptyContext env t []) () + +addToCtxt :: Name -> Term -> Type -> Context -> Context +addToCtxt n tm ty uctxt + = let ctxt = definitions uctxt + ctxt' = addDef n (Function ty tm, Public) ctxt in + uctxt { definitions = ctxt' } + +setAccess :: Name -> Accessibility -> Context -> Context +setAccess n a uctxt + = let ctxt = definitions uctxt + ctxt' = updateDef n (\ (d, _) -> (d, a)) ctxt in + uctxt { definitions = ctxt' } + +addCtxtDef :: Name -> Def -> Context -> Context +addCtxtDef n d c = let ctxt = definitions c + ctxt' = addDef n (d, Public) ctxt in + c { definitions = ctxt' } + +addTyDecl :: Name -> Type -> Context -> Context +addTyDecl n ty uctxt + = let ctxt = definitions uctxt + ctxt' = addDef n (TyDecl Ref ty, Public) ctxt in + uctxt { definitions = ctxt' } + +addDatatype :: Datatype Name -> Context -> Context +addDatatype (Data n tag ty cons) uctxt + = let ctxt = definitions uctxt + ty' = normalise uctxt [] ty + ctxt' = addCons 0 cons (addDef n + (TyDecl (TCon tag (arity ty')) ty, Public) ctxt) in + uctxt { definitions = ctxt' } + where + addCons tag [] ctxt = ctxt + addCons tag ((n, ty) : cons) ctxt + = let ty' = normalise uctxt [] ty in + addCons (tag+1) cons (addDef n + (TyDecl (DCon tag (arity ty')) ty, Public) ctxt) + +addCasedef :: Name -> Bool -> Bool -> Bool -> [(Term, Term)] -> [(Term, Term)] -> + Type -> Context -> Context +addCasedef n alwaysInline tcase covering ps psrt ty uctxt + = let ctxt = definitions uctxt + ps' = ps -- simpl ps in + ctxt' = case (simpleCase tcase covering ps', + simpleCase tcase covering psrt) of + (CaseDef args sc, CaseDef args' sc') -> + let inl = alwaysInline in + addDef n (CaseOp inl ty ps args sc args' sc', + Public) ctxt in + uctxt { definitions = ctxt' } + where simpl [] = [] + simpl ((l,r) : xs) = (l, simplify uctxt [] r) : simpl xs + +addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) -> Context -> Context +addOperator n ty a op uctxt + = let ctxt = definitions uctxt + ctxt' = addDef n (Operator ty a op, Public) ctxt in + uctxt { definitions = ctxt' } + +lookupTy :: Maybe [String] -> Name -> Context -> [Type] +lookupTy root n ctxt + = do def <- lookupCtxt root n (definitions ctxt) + case fst def of + (Function ty _) -> return ty + (TyDecl _ ty) -> return ty + (Operator ty _ _) -> return ty + (CaseOp _ ty _ _ _ _ _) -> return ty + +isConName :: Maybe [String] -> Name -> Context -> Bool +isConName root n ctxt + = or $ do def <- lookupCtxt root n (definitions ctxt) + case fst def of + (TyDecl (DCon _ _) _) -> return True + (TyDecl (TCon _ _) _) -> return True + _ -> return False + +lookupP :: Maybe [String] -> Name -> Context -> [Term] +lookupP root n ctxt + = do def <- lookupCtxt root n (definitions ctxt) + p <- case def of + (Function ty tm, a) -> return (P Ref n ty, a) + (TyDecl nt ty, a) -> return (P nt n ty, a) + (CaseOp _ ty _ _ _ _ _, a) -> return (P Ref n ty, a) + (Operator ty _ _, a) -> return (P Ref n ty, a) + case snd p of + Hidden -> [] + _ -> return (fst p) + +lookupDef :: Maybe [String] -> Name -> Context -> [Def] +lookupDef root n ctxt = map fst $ lookupCtxt root n (definitions ctxt) + +lookupDefAcc :: Maybe [String] -> Name -> Bool -> Context -> [(Def, Accessibility)] +lookupDefAcc root n mkpublic ctxt + = map mkp $ lookupCtxt root n (definitions ctxt) + where mkp (d, a) = if mkpublic then (d, Public) else (d, a) + +lookupVal :: Maybe [String] -> Name -> Context -> [Value] +lookupVal root n ctxt + = do def <- lookupCtxt root n (definitions ctxt) + case fst def of + (Function _ htm) -> return (veval ctxt [] htm) + (TyDecl nt ty) -> return (VP nt n (veval ctxt [] ty)) + +lookupTyEnv :: Name -> Env -> Maybe (Int, Type) +lookupTyEnv n env = li n 0 env where + li n i [] = Nothing + li n i ((x, b): xs) + | n == x = Just (i, binderTy b) + | otherwise = li n (i+1) xs + diff --git a/src/Core/ProofShell.hs b/src/Core/ProofShell.hs new file mode 100644 --- /dev/null +++ b/src/Core/ProofShell.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-} + +module Core.ProofShell where + +import Core.Typecheck +import Core.Evaluate +import Core.TT +import Core.ShellParser +import Core.Elaborate + +import Control.Monad.State +import System.Console.Haskeline + +data ShellState = ShellState + { ctxt :: Context, + prf :: Maybe ProofState, + deferred :: [(Name, ProofState)], + exitNow :: Bool + } + +initState c = ShellState c Nothing [] False + +processCommand :: Command -> ShellState -> (ShellState, String) +processCommand (Theorem n ty) state + = case check (ctxt state) [] ty of + OK (gl, t) -> + case isSet (ctxt state) [] t of + OK _ -> (state { prf = Just (newProof n (ctxt state) gl) }, "") + _ -> (state, "Goal is not a type") + err -> (state, show err) +processCommand Quit state = (state { exitNow = True }, "Bye bye") +processCommand (Eval t) state = + case check (ctxt state) [] t of + OK (val, ty) -> + let nf = normalise (ctxt state) [] val + tnf = normalise (ctxt state) [] ty in + (state, show nf ++ " : " ++ show ty) + err -> (state, show err) +processCommand (Print n) state = + case lookupDef Nothing n (ctxt state) of + [tm] -> (state, show tm) + _ -> (state, "No such name") +processCommand (Tac e) state + | Just ps <- prf state = case execElab () e ps of + OK (ES (ps', _) resp _) -> + if (not (done ps')) + then (state { prf = Just ps' }, resp) + else (state { prf = Nothing, + ctxt = addToCtxt (thname ps') + (pterm ps') + (ptype ps') + (context ps') }, resp) + err -> (state, show err) + | otherwise = (state, "No proof in progress") + +runShell :: ShellState -> InputT IO ShellState +runShell st = do (prompt, parser) <- + maybe (return ("TT# ", parseCommand)) + (\st -> do outputStrLn (show st) + return (show (thname st) ++ "# ", parseTactic)) + (prf st) + x <- getInputLine prompt + cmd <- case x of + Nothing -> return $ Right Quit + Just input -> return (parser input) + case cmd of + Left err -> do outputStrLn (show err) + runShell st + Right cmd -> do let (st', r) = processCommand cmd st + outputStrLn r + if (not (exitNow st')) then runShell st' + else return st' + diff --git a/src/Core/ProofState.hs b/src/Core/ProofState.hs new file mode 100644 --- /dev/null +++ b/src/Core/ProofState.hs @@ -0,0 +1,520 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-} + +{- Implements a proof state, some primitive tactics for manipulating + proofs, and some high level commands for introducing new theorems, + evaluation/checking inside the proof system, etc. --} + +module Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus, + Tactic(..), Goal(..), processTactic) where + +import Core.Typecheck +import Core.Evaluate +import Core.TT +import Core.Unify + +import Control.Monad.State +import Control.Applicative +import Data.List +import Debug.Trace + +data ProofState = PS { thname :: Name, + holes :: [Name], -- holes still to be solved + nextname :: Int, -- name supply + pterm :: Term, -- current proof term + ptype :: Type, -- original goal + unified :: (Name, [(Name, Term)]), + solved :: Maybe (Name, Term), + problems :: Fails, + injective :: [(Term, Term, Term)], + deferred :: [Name], -- names we'll need to define + instances :: [Name], -- instance arguments (for type classes) + previous :: Maybe ProofState, -- for undo + context :: Context, + plog :: String, + done :: Bool + } + +data Goal = GD { premises :: Env, + goalType :: Binder Term + } + +data Tactic = Attack + | Claim Name Raw + | Reorder Name + | Exact Raw + | Fill Raw + | PrepFill Name [Name] + | CompleteFill + | Regret + | Solve + | StartUnify Name + | EndUnify + | Compute + | EvalIn Raw + | CheckIn Raw + | Intro (Maybe Name) + | IntroTy Raw (Maybe Name) + | Forall Name Raw + | LetBind Name Raw Raw + | Rewrite Raw + | PatVar Name + | PatBind Name + | Focus Name + | Defer Name + | Instance Name + | MoveLast Name + | ProofState + | Undo + | QED + deriving Show + +-- Some utilites on proof and tactic states + +instance Show ProofState where + show (PS nm [] _ tm _ _ _ _ _ _ _ _ _ _ _) = show nm ++ ": no more goals" + show (PS nm (h:hs) _ tm _ _ _ _ _ i _ _ ctxt _ _) + = let OK g = goal (Just h) tm + wkenv = premises g in + "Other goals: " ++ show hs ++ "\n" ++ + showPs wkenv (reverse wkenv) ++ "\n" ++ + "-------------------------------- (" ++ show nm ++ + ") -------\n " ++ + show h ++ " : " ++ showG wkenv (goalType g) ++ "\n" + where showPs env [] = "" + showPs env ((n, Let t v):bs) + = " " ++ show n ++ " : " ++ + showEnv env ({- normalise ctxt env -} t) ++ " = " ++ + showEnv env ({- normalise ctxt env -} v) ++ + "\n" ++ showPs env bs + showPs env ((n, b):bs) + = " " ++ show n ++ " : " ++ + showEnv env ({- normalise ctxt env -} (binderTy b)) ++ + "\n" ++ showPs env bs + showG ps (Guess t v) = showEnv ps ({- normalise ctxt ps -} t) ++ + " =?= " ++ showEnv ps v + showG ps b = showEnv ps (binderTy b) + +same Nothing n = True +same (Just x) n = x == n + +hole (Hole _) = True +hole (Guess _ _) = True +hole _ = False + +holeName i = MN i "hole" + +unify' :: Context -> Env -> TT Name -> TT Name -> StateT TState TC [(Name, TT Name)] +unify' ctxt env topx topy = do (u, inj, fails) <- lift $ unify ctxt env topx topy + addInj inj + case fails of + [] -> return u + err -> + do ps <- get + put (ps { problems = err ++ problems ps }) + return [] + +getName :: Monad m => String -> StateT TState m Name +getName tag = do ps <- get + let n = nextname ps + put (ps { nextname = n+1 }) + return $ MN n tag + +action :: Monad m => (ProofState -> ProofState) -> StateT TState m () +action a = do ps <- get + put (a ps) + +addLog :: Monad m => String -> StateT TState m () +addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" }) + +newProof :: Name -> Context -> Type -> ProofState +newProof n ctxt ty = let h = holeName 0 + ty' = vToP ty in + PS n [h] 1 (Bind h (Hole ty') (P Bound h ty')) ty (h, []) + Nothing [] [] + [] [] + Nothing ctxt "" False + +type TState = ProofState -- [TacticAction]) +type RunTactic = Context -> Env -> Term -> StateT TState TC Term +type Hole = Maybe Name -- Nothing = default hole, first in list in proof state + +envAtFocus :: ProofState -> TC Env +envAtFocus ps + | not $ null (holes ps) = do g <- goal (Just (head (holes ps))) (pterm ps) + return (premises g) + | otherwise = fail "No holes" + +goalAtFocus :: ProofState -> TC (Binder Type) +goalAtFocus ps + | not $ null (holes ps) = do g <- goal (Just (head (holes ps))) (pterm ps) + return (goalType g) + +goal :: Hole -> Term -> TC Goal +goal h tm = g [] tm where + g env (Bind n b sc) | hole b && same h n = return $ GD env b + | otherwise + = gb env b `mplus` g ((n, b):env) sc + g env (App f a) = g env f `mplus` g env a + g env t = fail "Can't find hole" + + gb env (Let t v) = g env t `mplus` g env v + gb env (Guess t v) = g env t `mplus` g env v + gb env t = g env (binderTy t) + +tactic :: Hole -> RunTactic -> StateT TState TC () +tactic h f = do ps <- get + tm' <- atH (context ps) [] (pterm ps) + ps <- get -- might have changed while processing + put (ps { pterm = tm' }) + where + atH c env binder@(Bind n b sc) + | hole b && same h n = f c env binder + | otherwise + = liftM2 (Bind n) (atHb c env b) (atH c ((n, b) : env) sc) + atH c env (App f a) = liftM2 App (atH c env f) (atH c env a) + atH c env t = return t + + atHb c env (Let t v) = liftM2 Let (atH c env t) (atH c env v) + atHb c env (Guess t v) = liftM2 Guess (atH c env t) (atH c env v) + atHb c env t = do ty' <- atH c env (binderTy t) + return $ t { binderTy = ty' } + +attack :: RunTactic +attack ctxt env (Bind x (Hole t) sc) + = do h <- getName "hole" + action (\ps -> ps { holes = h : holes ps }) + return $ Bind x (Guess t (newtm h)) sc + where + newtm h = Bind h (Hole t) (P Bound h t) +attack ctxt env _ = fail "Not an attackable hole" + +claim :: Name -> Raw -> RunTactic +claim n ty ctxt env t = + do (tyv, tyt) <- lift $ check ctxt env ty + lift $ isSet ctxt env tyt + action (\ps -> let (g:gs) = holes ps in + ps { holes = g : n : gs } ) + return $ Bind n (Hole tyv) t -- (weakenTm 1 t) + +reorder_claims :: RunTactic +reorder_claims ctxt env t + = -- trace (showSep "\n" (map show (scvs t))) $ + let (bs, sc) = scvs t [] + newbs = reverse (sortB (reverse bs)) in + traceWhen (bs /= newbs) (show bs ++ "\n ==> \n" ++ show newbs) $ + return (bindAll newbs sc) + where scvs (Bind n b@(Hole _) sc) acc = scvs sc ((n, b):acc) + scvs sc acc = (reverse acc, sc) + + sortB :: [(Name, Binder (TT Name))] -> [(Name, Binder (TT Name))] + sortB [] = [] + sortB (x:xs) | all (noOcc x) xs = x : sortB xs + | otherwise = sortB (insertB x xs) + + insertB x [] = [x] + insertB x (y:ys) | all (noOcc x) (y:ys) = x : y : ys + | otherwise = y : insertB x ys + + noOcc (n, _) (_, Let t v) = noOccurrence n t && noOccurrence n v + noOcc (n, _) (_, Guess t v) = noOccurrence n t && noOccurrence n v + noOcc (n, _) (_, b) = noOccurrence n (binderTy b) + +focus :: Name -> RunTactic +focus n ctxt env t = do action (\ps -> let hs = holes ps in + if n `elem` hs + then ps { holes = n : (hs \\ [n]) } + else ps) + return t + +movelast :: Name -> RunTactic +movelast n ctxt env t = do action (\ps -> let hs = holes ps in + if n `elem` hs + then ps { holes = (hs \\ [n]) ++ [n] } + else ps) + return t + +instanceArg :: Name -> RunTactic +instanceArg n ctxt env (Bind x (Hole t) sc) + = do action (\ps -> let hs = holes ps + is = instances ps in + ps { holes = (hs \\ [x]) ++ [x], + instances = x:is }) + return (Bind x (Hole t) sc) + +defer :: Name -> RunTactic +defer n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' = + do action (\ps -> let hs = holes ps in + ps { holes = hs \\ [x] }) + return (Bind n (GHole (mkTy (reverse env) t)) + (mkApp (P Ref n ty) (map getP (reverse env)))) + where + mkTy [] t = t + mkTy ((n,b) : bs) t = Bind n (Pi (binderTy b)) (mkTy bs t) + + getP (n, b) = P Bound n (binderTy b) + +-- Hmmm. YAGNI? +regret :: RunTactic +regret = undefined + +addInj :: [(Term, Term, Term)] -> StateT TState TC () +addInj inj = do ps <- get + put (ps { injective = inj ++ injective ps }) + +exact :: Raw -> RunTactic +exact guess ctxt env (Bind x (Hole ty) sc) = + do (val, valty) <- lift $ check ctxt env guess + lift $ converts ctxt env valty ty + return $ Bind x (Guess ty val) sc +exact _ _ _ _ = fail "Can't fill here." + +-- As exact, but attempts to solve other goals by unification + +fill :: Raw -> RunTactic +fill guess ctxt env (Bind x (Hole ty) sc) = + do (val, valty) <- lift $ check ctxt env guess + s <- get + ns <- unify' ctxt env valty ty + ps <- get + let (uh, uns) = unified ps + put (ps { unified = (uh, uns ++ ns) }) +-- addLog (show (uh, uns ++ ns)) + return $ Bind x (Guess ty val) sc +fill _ _ _ _ = fail "Can't fill here." + +prep_fill :: Name -> [Name] -> RunTactic +prep_fill f as ctxt env (Bind x (Hole ty) sc) = + do let val = mkApp (P Ref f undefined) (map (\n -> P Ref n undefined) as) + return $ Bind x (Guess ty val) sc +prep_fill f as ctxt env t = fail $ "Can't prepare fill at " ++ show t + +complete_fill :: RunTactic +complete_fill ctxt env (Bind x (Guess ty val) sc) = + do let guess = forget val + (val', valty) <- lift $ check ctxt env guess + ns <- unify' ctxt env valty ty + ps <- get + let (uh, uns) = unified ps + put (ps { unified = (uh, uns ++ ns) }) + return $ Bind x (Guess ty val) sc +complete_fill ctxt env t = fail $ "Can't complete fill at " ++ show t + +solve :: RunTactic +solve ctxt env (Bind x (Guess ty val) sc) + | pureTerm val = do ps <- get + let (uh, uns) = unified ps + action (\ps -> ps { holes = holes ps \\ [x], + solved = Just (x, val), + -- unified = (uh, uns ++ [(x, val)]), + instances = instances ps \\ [x] }) + return $ {- Bind x (Let ty val) sc -} instantiate val (pToV x sc) + | otherwise = fail $ "I see a hole in your solution. " ++ showEnv env val +solve _ _ h = fail $ "Not a guess " ++ show h + +introTy :: Raw -> Maybe Name -> RunTactic +introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = + do let n = case mn of + Just name -> name + Nothing -> x + let t' = normalise ctxt env t + (tyv, tyt) <- lift $ check ctxt env ty +-- ns <- lift $ unify ctxt env tyv t' + case t' of + Bind y (Pi s) t -> let t' = instantiate (P Bound n s) (pToV y t) in + do ns <- unify' ctxt env s tyv + ps <- get + let (uh, uns) = unified ps + put (ps { unified = (uh, uns ++ ns) }) + return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t')) + _ -> fail "Nothing to introduce" +introTy ty n ctxt env _ = fail "Can't introduce here." + +intro :: Maybe Name -> RunTactic +intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = + do let n = case mn of + Just name -> name + Nothing -> x + let t' = normalise ctxt env t + case t' of + Bind y (Pi s) t -> let t' = instantiate (P Bound n s) (pToV y t) in + return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t')) + _ -> fail "Nothing to introduce" +intro n ctxt env _ = fail "Can't introduce here." + +forall :: Name -> Raw -> RunTactic +forall n ty ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = + do (tyv, tyt) <- lift $ check ctxt env ty + lift $ isSet ctxt env tyt + lift $ isSet ctxt env t + return $ Bind n (Pi tyv) (Bind x (Hole t) (P Bound x t)) +forall n ty ctxt env _ = fail "Can't pi bind here" + +patvar :: Name -> RunTactic +patvar n ctxt env (Bind x (Hole t) sc) = + do action (\ps -> ps { holes = holes ps \\ [x] }) + return $ Bind n (PVar t) (instantiate (P Bound n t) (pToV x sc)) +patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm + +letbind :: Name -> Raw -> Raw -> RunTactic +letbind n ty val ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = + do (tyv, tyt) <- lift $ check ctxt env ty + (valv, valt) <- lift $ check ctxt env val + lift $ isSet ctxt env tyt + return $ Bind n (Let tyv valv) (Bind x (Hole t) (P Bound x t)) +letbind n ty val ctxt env _ = fail "Can't let bind here" + +rewrite :: Raw -> RunTactic +rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' = + do (tmv, tmt) <- lift $ check ctxt env tm + case unApply tmt of + (P _ (UN "=") _, [lt,rt,l,r]) -> + do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t) + let newt = mkP l r l t + let sc = forget $ (Bind x (Hole newt) + (mkApp (P Ref (UN "replace") (Set (UVal 0))) + [lt, l, r, p, tmv, xp])) + (scv, sct) <- lift $ check ctxt env sc + return scv + _ -> fail "Not an equality type" + where + -- to make the P for rewrite, replace syntactic occurrences of l in ty with + -- and x, and put \x : lt in front + mkP lt l r ty | l == ty = lt + mkP lt l r (App f a) = let f' = if (r /= f) then mkP lt l r f else f + a' = if (r /= a) then mkP lt l r a else a in + App f' a' + mkP lt l r x = x + + rname = MN 0 "replaced" +rewrite _ _ _ _ = fail "Can't rewrite here" + +patbind :: Name -> RunTactic +patbind n ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = + do let t' = normalise ctxt env t + case t' of + Bind y (PVTy s) t -> let t' = instantiate (P Bound n s) (pToV y t) in + return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t')) + _ -> fail "Nothing to pattern bind" +patbind n ctxt env _ = fail "Can't pattern bind here" + +compute :: RunTactic +compute ctxt env (Bind x (Hole ty) sc) = + do return $ Bind x (Hole (normalise ctxt env ty)) sc + +check_in :: Raw -> RunTactic +check_in t ctxt env tm = + do (val, valty) <- lift $ check ctxt env t + addLog (showEnv env val ++ " : " ++ showEnv env valty) + return tm + +eval_in :: Raw -> RunTactic +eval_in t ctxt env tm = + do (val, valty) <- lift $ check ctxt env t + let val' = normalise ctxt env val + let valty' = normalise ctxt env valty + addLog (showEnv env val ++ " : " ++ + showEnv env valty ++ +-- " in " ++ show env ++ + " ==>\n " ++ + showEnv env val' ++ " : " ++ + showEnv env valty') + return tm + +start_unify :: Name -> RunTactic +start_unify n ctxt env tm = do action (\ps -> ps { unified = (n, []) }) + return tm + +tmap f (a, b, c) = (f a, b, c) + +solve_unified :: RunTactic +solve_unified ctxt env tm = + do ps <- get + let (_, ns) = unified ps + action (\ps -> ps { holes = holes ps \\ map fst ns }) + action (\ps -> ps { pterm = updateSolved ns (pterm ps) }) + action (\ps -> ps { injective = map (tmap (updateSolved ns)) (injective ps) }) + return (updateSolved ns tm) + +updateSolved xs (Bind n (Hole ty) t) + | Just v <- lookup n xs = instantiate v (pToV n (updateSolved xs t)) +updateSolved xs (Bind n b t) + | otherwise = Bind n (fmap (updateSolved xs) b) (updateSolved xs t) +updateSolved xs (App f a) = App (updateSolved xs f) (updateSolved xs a) +updateSolved xs (P _ n _) + | Just v <- lookup n xs = v +updateSolved xs t = t + +updateProblems ns [] = [] +updateProblems ns ((x, y, env, err) : ps) = + let x' = updateSolved ns x + y' = updateSolved ns y in + (x',y',env,err) : updateProblems ns ps + +processTactic :: Tactic -> ProofState -> TC (ProofState, String) +processTactic QED ps = case holes ps of + [] -> do let tm = {- normalise (context ps) [] -} (pterm ps) + (tm', ty', _) <- recheck (context ps) [] (forget tm) tm + return (ps { done = True, pterm = tm' }, + "Proof complete: " ++ showEnv [] tm') + _ -> fail "Still holes to fill." +processTactic ProofState ps = return (ps, showEnv [] (pterm ps)) +processTactic Undo ps = case previous ps of + Nothing -> fail "Nothing to undo." + Just pold -> return (pold, "") +processTactic EndUnify ps + = let (h, ns) = unified ps + ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns + tm' = -- trace ("Updating " ++ show ns' ++ " in " ++ show (pterm ps)) $ + updateSolved ns' (pterm ps) + probs' = updateProblems ns' (problems ps) in + case probs' of + [] -> return (ps { pterm = tm', + unified = (h, []), + injective = map (tmap (updateSolved ns')) + (injective ps), + holes = holes ps \\ map fst ns' }, "") + errs@((_,_,_,err):_) -> tfail err +processTactic (Reorder n) ps + = do ps' <- execStateT (tactic (Just n) reorder_claims) ps + return (ps' { previous = Just ps, plog = "" }, plog ps') +processTactic t ps + = case holes ps of + [] -> fail "Nothing to fill in." + (h:_) -> do ps' <- execStateT (process t h) ps + let pterm' = case solved ps' of + Just s -> updateSolved [s] (pterm ps') + _ -> pterm ps' + return (ps' { pterm = pterm', + solved = Nothing, + previous = Just ps, plog = "" }, plog ps') + +process :: Tactic -> Name -> StateT TState TC () +process EndUnify _ + = do ps <- get + let (h, _) = unified ps + tactic (Just h) solve_unified +process t h = tactic (Just h) (mktac t) + where mktac Attack = attack + mktac (Claim n r) = claim n r + mktac (Exact r) = exact r + mktac (Fill r) = fill r + mktac (PrepFill n ns) = prep_fill n ns + mktac CompleteFill = complete_fill + mktac Regret = regret + mktac Solve = solve + mktac (StartUnify n) = start_unify n + mktac Compute = compute + mktac (Intro n) = intro n + mktac (IntroTy ty n) = introTy ty n + mktac (Forall n t) = forall n t + mktac (LetBind n t v) = letbind n t v + mktac (Rewrite t) = rewrite t + mktac (PatVar n) = patvar n + mktac (PatBind n) = patbind n + mktac (CheckIn r) = check_in r + mktac (EvalIn r) = eval_in r + mktac (Focus n) = focus n + mktac (Defer n) = defer n + mktac (Instance n) = instanceArg n + mktac (MoveLast n) = movelast n + diff --git a/src/Core/ShellParser.hs b/src/Core/ShellParser.hs new file mode 100644 --- /dev/null +++ b/src/Core/ShellParser.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +module Core.ShellParser(parseCommand, parseTactic) where + +import Core.TT +import Core.Elaborate +import Core.CoreParser + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as PTok + +import Debug.Trace + +type TokenParser a = PTok.TokenParser a + +lexer :: TokenParser () +lexer = PTok.makeTokenParser haskellDef + +whiteSpace= PTok.whiteSpace lexer +lexeme = PTok.lexeme lexer +symbol = PTok.symbol lexer +natural = PTok.natural lexer +parens = PTok.parens lexer +semi = PTok.semi lexer +comma = PTok.comma lexer +identifier= PTok.identifier lexer +reserved = PTok.reserved lexer +operator = PTok.operator lexer +reservedOp= PTok.reservedOp lexer +lchar = lexeme.char + +parseCommand = parse pCommand "(input)" +parseTactic = parse (pTactic >>= return . Tac) "(input)" + +pCommand :: Parser Command +pCommand = do reserved "theorem"; n <- iName []; lchar ':'; ty <- pTerm + return (Theorem n ty) + <|> do reserved "eval"; tm <- pTerm + return (Eval tm) + <|> do reserved "print"; n <- iName []; return (Print n) + <|> do reserved "quit"; + return Quit + +pTactic :: Parser (Elab ()) +pTactic = do reserved "attack"; return attack + <|> do reserved "claim"; n <- iName []; lchar ':'; ty <- pTerm + return (claim n ty) + <|> do reserved "regret"; return regret + <|> do reserved "exact"; tm <- pTerm; return (exact tm) + <|> do reserved "fill"; tm <- pTerm; return (fill tm) + <|> do reserved "apply"; tm <- pTerm; args <- many pArgType; + return (discard (apply tm (map (\x -> (x,0)) args))) + <|> do reserved "solve"; return solve + <|> do reserved "compute"; return compute + <|> do reserved "intro"; n <- iName []; return (intro (Just n)) + <|> do reserved "forall"; n <- iName []; lchar ':'; ty <- pTerm + return (forall n ty) + <|> do reserved "arg"; n <- iName []; t <- iName []; return (arg n t) + <|> do reserved "patvar"; n <- iName []; return (patvar n) +-- <|> do reserved "patarg"; n <- iName []; t <- iName []; return (patarg n t) + <|> do reserved "eval"; t <- pTerm; return (eval_in t) + <|> do reserved "check"; t <- pTerm; return (check_in t) + <|> do reserved "focus"; n <- iName []; return (focus n) + <|> do reserved "state"; return proofstate + <|> do reserved "undo"; return undo + <|> do reserved "qed"; return (discard qed) + +pArgType :: Parser Bool +pArgType = do lchar '_'; return True -- implicit (machine fills in) + <|> do lchar '?'; return False -- user fills in + diff --git a/src/Core/TT.hs b/src/Core/TT.hs new file mode 100644 --- /dev/null +++ b/src/Core/TT.hs @@ -0,0 +1,591 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DeriveFunctor #-} + +module Core.TT where + +import Control.Monad.State +import Debug.Trace +import qualified Data.Map as Map +import Data.Char +import Data.List +import qualified Data.Binary as B +import Data.Binary hiding (get, put) + +{- The language has: + * Full dependent types + * A hierarchy of universes, with cumulativity: Set : Set1, Set1 : Set2, ... + * Pattern matching letrec binding + * (primitive types defined externally) + + Some technical stuff: + * Typechecker is kept as simple as possible + - no unification, just a checker for incomplete terms. + * We have a simple collection of tactics which we use to elaborate source + programs with implicit syntax into fully explicit terms. +-} + +data Option = SetInSet + | CheckConv + deriving Eq + +data FC = FC { fc_fname :: String, + fc_line :: Int } + deriving Eq +{-! +deriving instance Binary FC +!-} + +instance Show FC where + show (FC f l) = f ++ ":" ++ show l + +data Err = Msg String + | CantUnify Term Term Err Int -- Int is 'score' - how much we did unify + | NotInjective Term Term Term + | IncompleteTerm Term + | UniverseError + | ProgramLineComment + | At FC Err + deriving Eq + +score :: Err -> Int +score (CantUnify _ _ m s) = s + score m +score _ = 0 + +instance Show Err where + show (Msg s) = s + show (CantUnify l r e i) = "CantUnify " ++ show l ++ " " ++ show r ++ " " + ++ show e ++ " " ++ show i + show _ = "Error" + +data TC a = OK a + | Error Err + deriving (Eq, Functor) + +instance Show a => Show (TC a) where + show (OK x) = show x + show (Error str) = "Error: " ++ show str + +-- at some point, this instance should also carry type checking options +-- (e.g. Set:Set) + +instance Monad TC where + return = OK + x >>= k = case x of + OK v -> k v + Error e -> Error e + fail e = Error (Msg e) + +tfail :: Err -> TC a +tfail e = Error e + +trun :: FC -> TC a -> TC a +trun fc (OK a) = OK a +trun fc (Error e) = Error (At fc e) + +instance MonadPlus TC where + mzero = fail "Unknown error" + (OK x) `mplus` _ = OK x + _ `mplus` (OK y) = OK y + err `mplus` _ = err + +discard :: Monad m => m a -> m () +discard f = f >> return () + +showSep :: String -> [String] -> String +showSep sep [] = "" +showSep sep [x] = x +showSep sep (x:xs) = x ++ sep ++ showSep sep xs + +pmap f (x, y) = (f x, f y) + +traceWhen True msg a = trace msg a +traceWhen False _ a = a + +-- RAW TERMS ---------------------------------------------------------------- + +-- Names are hierarchies of strings, describing scope (so no danger of +-- duplicate names, but need to be careful on lookup). +-- Also MN for machine chosen names + +data Name = UN String + | NS Name [String] -- root, namespaces + | MN Int String + deriving (Eq, Ord) +{-! +deriving instance Binary Name +!-} + +instance Show Name where + show (UN n) = n + show (NS n s) = showSep "." (reverse s) ++ "." ++ show n + show (MN i s) = "{" ++ s ++ show i ++ "}" + + +-- Contexts allow us to map names to things. A root name maps to a collection +-- of things in different namespaces with that name. + +type Ctxt a = Map.Map Name (Map.Map Name a) +emptyContext = Map.empty + +nsroot (NS n _) = n +nsroot n = n + +addDef :: Name -> a -> Ctxt a -> Ctxt a +addDef n v ctxt = case Map.lookup (nsroot n) ctxt of + Nothing -> Map.insert (nsroot n) + (Map.insert n v Map.empty) ctxt + Just xs -> Map.insert (nsroot n) + (Map.insert n v xs) ctxt + +{- lookup a name in the context, given an optional namespace. + The name (n) may itself have a (partial) namespace given. + + Rules for resolution: + - if an explicit namespace is given, return the names which match it. If none + match, return all names. + - if the name has has explicit namespace given, return the names which match it + and ignore the given namespace. + - otherwise, return all names. + +-} + +lookupCtxtName :: Maybe [String] -> Name -> Ctxt a -> [(Name, a)] +lookupCtxtName nspace n ctxt = case Map.lookup (nsroot n) ctxt of + Just xs -> filterNS (Map.toList xs) + Nothing -> [] + where + filterNS [] = [] + filterNS ((found, v) : xs) + | nsmatch n found = (found, v) : filterNS xs + | otherwise = filterNS xs + + nsmatch (NS n ns) (NS p ps) = ns `isPrefixOf` ps + nsmatch (NS _ _) _ = False + nsmatch looking found = True + +lookupCtxt :: Maybe [String] -> Name -> Ctxt a -> [a] +lookupCtxt ns n ctxt = map snd (lookupCtxtName ns n ctxt) + +updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a +updateDef n f ctxt + = let ds = lookupCtxtName Nothing n ctxt in + foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds + +toAlist :: Ctxt a -> [(Name, a)] +toAlist ctxt = let allns = map snd (Map.toList ctxt) in + concat (map (Map.toList) allns) + +addAlist :: Show a => [(Name, a)] -> Ctxt a -> Ctxt a +addAlist [] ctxt = ctxt +addAlist ((n, tm) : ds) ctxt = addDef n tm (addAlist ds ctxt) + +data Const = I Int | BI Integer | Fl Double | Ch Char | Str String + | IType | BIType | FlType | ChType | StrType + | PtrType | Forgot + deriving Eq +{-! +deriving instance Binary Const +!-} + +data Raw = Var Name + | RBind Name (Binder Raw) Raw + | RApp Raw Raw + | RSet + | RForce Raw + | RConstant Const + deriving (Show, Eq) +{-! +deriving instance Binary Raw +!-} + +data Binder b = Lam { binderTy :: b } + | Pi { binderTy :: b } + | Let { binderTy :: b, + binderVal :: b } + | NLet { binderTy :: b, + binderVal :: b } + | Hole { binderTy :: b} + | GHole { binderTy :: b} + | Guess { binderTy :: b, + binderVal :: b } + | PVar { binderTy :: b } + | PVTy { binderTy :: b } + deriving (Show, Eq, Functor) +{-! +deriving instance Binary Binder +!-} + +fmapMB :: Monad m => (a -> m b) -> Binder a -> m (Binder b) +fmapMB f (Let t v) = liftM2 Let (f t) (f v) +fmapMB f (NLet t v) = liftM2 NLet (f t) (f v) +fmapMB f (Guess t v) = liftM2 Guess (f t) (f v) +fmapMB f (Lam t) = liftM Lam (f t) +fmapMB f (Pi t) = liftM Pi (f t) +fmapMB f (Hole t) = liftM Hole (f t) +fmapMB f (GHole t) = liftM GHole (f t) +fmapMB f (PVar t) = liftM PVar (f t) +fmapMB f (PVTy t) = liftM PVTy (f t) + +raw_apply :: Raw -> [Raw] -> Raw +raw_apply f [] = f +raw_apply f (a : as) = raw_apply (RApp f a) as + +raw_unapply :: Raw -> (Raw, [Raw]) +raw_unapply t = ua [] t where + ua args (RApp f a) = ua (a:args) f + ua args t = (t, args) + +data RawFun = RawFun { rtype :: Raw, + rval :: Raw + } + deriving Show + +data RawDatatype = RDatatype Name Raw [(Name, Raw)] + deriving Show + +data RDef = RFunction RawFun + | RConst Raw + | RData RawDatatype + deriving Show + +type RProgram = [(Name, RDef)] + +-- WELL TYPED TERMS --------------------------------------------------------- + +data UExp = UVar Int -- universe variable + | UVal Int -- explicit universe level + deriving (Eq, Ord) + +-- We assume that universe levels have been checked, so anything external +-- can just have the same universe variable and we won't get any new +-- cycles. + +instance Binary UExp where + put x = return () + get = return (UVar (-1)) + +instance Show UExp where + show (UVar x) | x < 26 = [toEnum (x + fromEnum 'a')] + | otherwise = toEnum ((x `mod` 26) + fromEnum 'a') : show (x `div` 26) + show (UVal x) = show x +-- show (UMax l r) = "max(" ++ show l ++ ", " ++ show r ++")" + +data UConstraint = ULT UExp UExp + | ULE UExp UExp + deriving Eq + +instance Show UConstraint where + show (ULT x y) = show x ++ " < " ++ show y + show (ULE x y) = show x ++ " <= " ++ show y + +type UCs = (Int, [UConstraint]) + +data NameType = Bound | Ref | DCon Int Int | TCon Int Int + deriving (Show) +{-! +deriving instance Binary NameType +!-} + +instance Eq NameType where + Bound == Bound = True + Ref == Ref = True + DCon _ a == DCon _ b = (a == b) -- ignore tag + TCon _ a == TCon _ b = (a == b) -- ignore tag + _ == _ = False + +data TT n = P NameType n (TT n) -- embed type + | V Int + | Bind n (Binder (TT n)) (TT n) + | App (TT n) (TT n) -- function, function type, arg + | Constant Const + | Erased + | Set UExp + deriving Functor +{-! +deriving instance Binary TT +!-} + +type EnvTT n = [(n, Binder (TT n))] + +data Datatype n = Data { d_typename :: n, + d_typetag :: Int, + d_type :: (TT n), + d_cons :: [(n, TT n)] } + deriving (Show, Functor, Eq) + +instance Eq n => Eq (TT n) where + (==) (P xt x _) (P yt y _) = xt == yt && x == y + (==) (V x) (V y) = x == y + (==) (Bind _ xb xs) (Bind _ yb ys) = xb == yb && xs == ys + (==) (App fx ax) (App fy ay) = fx == fy && ax == ay + (==) (Set _) (Set _) = True -- deal with constraints later + (==) (Constant x) (Constant y) = x == y + (==) Erased _ = True + (==) _ Erased = True + (==) _ _ = False + +convEq :: Eq n => TT n -> TT n -> StateT UCs TC Bool +convEq (P xt x _) (P yt y _) = return (xt == yt && x == y) +convEq (V x) (V y) = return (x == y) +convEq (Bind _ xb xs) (Bind _ yb ys) + = liftM2 (&&) (convEqB xb yb) (convEq xs ys) + where convEqB (Let v t) (Let v' t') = liftM2 (&&) (convEq v v') (convEq t t') + convEqB (Guess v t) (Guess v' t') = liftM2 (&&) (convEq v v') (convEq t t') + convEqB b b' = convEq (binderTy b) (binderTy b') +convEq (App fx ax) (App fy ay) = liftM2 (&&) (convEq fx fy) (convEq ax ay) +convEq (Constant x) (Constant y) = return (x == y) +convEq (Set x) (Set y) = do (v, cs) <- get + put (v, ULE x y : cs) + return True +convEq Erased _ = return True +convEq _ Erased = return True +convEq _ _ = return False + +-- A few handy operations on well typed terms: + +isInjective :: TT n -> Bool +isInjective (P (DCon _ _) _ _) = True +isInjective (P (TCon _ _) _ _) = True +isInjective (Constant _) = True +isInjective (Set x) = True +isInjective (Bind _ (Pi _) sc) = True +isInjective (App f a) = isInjective f +isInjective _ = False + +instantiate :: TT n -> TT n -> TT n +instantiate e = subst 0 where + subst i (V x) | i == x = e + subst i (Bind x b sc) = Bind x (fmap (subst i) b) (subst (i+1) sc) + subst i (App f a) = App (subst i f) (subst i a) + subst i t = t + +pToV :: Eq n => n -> TT n -> TT n +pToV n = pToV' n 0 +pToV' n i (P _ x _) | n == x = V i +pToV' n i (Bind x b sc) + | n == x = Bind x (fmap (pToV' n i) b) sc + | otherwise = Bind x (fmap (pToV' n i) b) (pToV' n (i+1) sc) +pToV' n i (App f a) = App (pToV' n i f) (pToV' n i a) +pToV' n i t = t + +-- Convert several names. First in the list comes out as V 0 +pToVs :: Eq n => [n] -> TT n -> TT n +pToVs ns tm = pToVs' ns tm 0 where + pToVs' [] tm i = tm + pToVs' (n:ns) tm i = pToV' n i (pToVs' ns tm (i+1)) + +vToP :: TT n -> TT n +vToP = vToP' [] where + vToP' env (V i) = let (n, b) = (env !! i) in + P Bound n (binderTy b) + vToP' env (Bind n b sc) = let b' = fmap (vToP' env) b in + Bind n b' (vToP' ((n, b'):env) sc) + vToP' env (App f a) = App (vToP' env f) (vToP' env a) + vToP' env t = t + +finalise :: Eq n => TT n -> TT n +finalise (Bind x b sc) = Bind x (fmap finalise b) (pToV x (finalise sc)) +finalise (App f a) = App (finalise f) (finalise a) +finalise t = t + +subst :: Eq n => n -> TT n -> TT n -> TT n +subst n v tm = instantiate v (pToV n tm) + +substNames :: Eq n => [(n, TT n)] -> TT n -> TT n +substNames [] t = t +substNames ((n, tm) : xs) t = subst n tm (substNames xs t) + +-- Returns true if V 0 and bound name n do not occur in the term + +noOccurrence :: Eq n => n -> TT n -> Bool +noOccurrence n t = no' 0 t + where + no' i (V x) = not (i == x) + no' i (P Bound x _) = not (n == x) + no' i (Bind n b sc) = noB' i b && no' (i+1) sc + where noB' i (Let t v) = no' i t && no' i v + noB' i (Guess t v) = no' i t && no' i v + noB' i b = no' i (binderTy b) + no' i (App f a) = no' i f && no' i a + no' i _ = True + +-- Return the arity of a (normalised) type + +arity :: TT n -> Int +arity (Bind n (Pi t) sc) = 1 + arity sc +arity _ = 0 + +-- deconstruct an application; returns the function and a list of arguments + +unApply :: TT n -> (TT n, [TT n]) +unApply t = ua [] t where + ua args (App f a) = ua (a:args) f + ua args t = (t, args) + +mkApp :: TT n -> [TT n] -> TT n +mkApp f [] = f +mkApp f (a:as) = mkApp (App f a) as + +forget :: TT Name -> Raw +forget tm = fe [] tm + where + fe env (P _ n _) = Var n + fe env (V i) = Var (env !! i) + fe env (Bind n b sc) = RBind n (fmap (fe env) b) + (fe (n:env) sc) + fe env (App f a) = RApp (fe env f) (fe env a) + fe env (Constant c) + = RConstant c + fe env (Set i) = RSet + fe env Erased = RConstant Forgot + +bindAll :: [(n, Binder (TT n))] -> TT n -> TT n +bindAll [] t =t +bindAll ((n, b) : bs) t = Bind n b (bindAll bs t) + +bindTyArgs :: (TT n -> Binder (TT n)) -> [(n, TT n)] -> TT n -> TT n +bindTyArgs b xs = bindAll (map (\ (n, ty) -> (n, b ty)) xs) + +getArgTys :: TT n -> [(n, TT n)] +getArgTys (Bind n (Pi t) sc) = (n, t) : getArgTys sc +getArgTys _ = [] + +getRetTy :: TT n -> TT n +getRetTy (Bind n (PVar _) sc) = getRetTy sc +getRetTy (Bind n (PVTy _) sc) = getRetTy sc +getRetTy (Bind n (Pi _) sc) = getRetTy sc +getRetTy sc = sc + +uniqueName :: Name -> [Name] -> Name +uniqueName n hs | n `elem` hs = uniqueName (nextName n) hs + | otherwise = n + +nextName (NS x s) = NS (nextName x) s +nextName (MN i n) = MN (i+1) n +nextName (UN x) = let (num', nm') = span isDigit (reverse x) + nm = reverse nm' + num = readN (reverse num') in + UN (nm ++ show (num+1)) + where + readN "" = 0 + readN x = read x + +type Term = TT Name +type Type = Term + +type Env = EnvTT Name + +-- an environment with de Bruijn indices 'normalised' so that they all refer to +-- this environment + +newtype WkEnvTT n = Wk (EnvTT n) +type WkEnv = WkEnvTT Name + +instance (Eq n, Show n) => Show (TT n) where + show t = showEnv [] t + +instance Show Const where + show (I i) = show i + show (BI i) = show i ++ "L" + show (Fl f) = show f + show (Ch c) = show c + show (Str s) = show s + show IType = "Int" + show BIType = "Integer" + show FlType = "Float" + show ChType = "Char" + show StrType = "String" + show PtrType = "Ptr" + +showEnv env t = showEnv' env t False +showEnvDbg env t = showEnv' env t True + +showEnv' env t dbg = se 10 env t where + se p env (P nt n t) = show n + ++ if dbg then "{" ++ show nt ++ " : " ++ se 10 env t ++ "}" else "" + se p env (V i) | i < length env = (show $ fst $ env!!i) ++ + if dbg then "{" ++ show i ++ "}" else "" + | otherwise = "!!V " ++ show i ++ "!!" + se p env (Bind n b@(Pi t) sc) + | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ " -> " ++ se 10 ((n,b):env) sc + se p env (Bind n b sc) = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc + se p env (App f a) = bracket p 1 $ se 1 env f ++ " " ++ se 0 env a + se p env (Constant c) = show c + se p env Erased = "[__]" + se p env (Set i) = "Set " ++ show i + + sb env n (Lam t) = showb env "\\ " " => " n t + sb env n (Hole t) = showb env "? " ". " n t + sb env n (GHole t) = showb env "?defer " ". " n t + sb env n (Pi t) = showb env "(" ") -> " n t + sb env n (PVar t) = showb env "pat " ". " n t + sb env n (PVTy t) = showb env "pty " ". " n t + sb env n (Let t v) = showbv env "let " " in " n t v + sb env n (Guess t v) = showbv env "?? " " in " n t v + + showb env op sc n t = op ++ show n ++ " : " ++ se 10 env t ++ sc + showbv env op sc n t v = op ++ show n ++ " : " ++ se 10 env t ++ " = " ++ + se 10 env v ++ sc + + bracket outer inner str | inner > outer = "(" ++ str ++ ")" + | otherwise = str + +-- Check whether a term has any holes in it - impure if so + +pureTerm :: TT n -> Bool +pureTerm (App f a) = pureTerm f && pureTerm a +pureTerm (Bind n b sc) = pureBinder b && pureTerm sc where + pureBinder (Hole _) = False + pureBinder (Guess _ _) = False + pureBinder (Let t v) = pureTerm t && pureTerm v + pureBinder t = pureTerm (binderTy t) +pureTerm _ = True + +-- weaken a term by adding i to each de Bruijn index (i.e. lift it over i bindings) + +weakenTm :: Int -> TT n -> TT n +weakenTm i t = wk i 0 t + where wk i min (V x) | x >= min = V (i + x) + wk i m (App f a) = App (wk i m f) (wk i m a) + wk i m (Bind x b sc) = Bind x (wkb i m b) (wk i (m + 1) sc) + wk i m t = t + wkb i m t = fmap (wk i m) t + +-- weaken an environment so that all the de Bruijn indices are correct according +-- to the latest bound variable + +weakenEnv :: EnvTT n -> EnvTT n +weakenEnv env = wk (length env - 1) env + where wk i [] = [] + wk i ((n, b) : bs) = (n, weakenTmB i b) : wk (i - 1) bs + weakenTmB i (Let t v) = Let (weakenTm i t) (weakenTm i v) + weakenTmB i (Guess t v) = Guess (weakenTm i t) (weakenTm i v) + weakenTmB i t = t { binderTy = weakenTm i (binderTy t) } + +weakenTmEnv :: Int -> EnvTT n -> EnvTT n +weakenTmEnv i = map (\ (n, b) -> (n, fmap (weakenTm i) b)) + +orderPats :: Term -> Term +orderPats tm = op [] tm + where + op ps (Bind n (PVar t) sc) = op ((n, t) : ps) sc + op ps sc = bindAll (map (\ (n, t) -> (n, PVar t)) (sortP ps)) sc + + sortP ps = pick [] (reverse ps) + + namesIn (P _ n _) = [n] + namesIn (Bind n b t) = nub $ nb b ++ (namesIn t \\ [n]) + where nb (Let t v) = nub (namesIn t) ++ nub (namesIn v) + nb (Guess t v) = nub (namesIn t) ++ nub (namesIn v) + nb t = namesIn (binderTy t) + namesIn (App f a) = nub (namesIn f ++ namesIn a) + namesIn _ = [] + + pick acc [] = reverse acc + pick acc ((n, t) : ps) = pick (insert n t acc) ps + + insert n t [] = [(n, t)] + insert n t ((n',t') : ps) + | n `elem` (namesIn t' ++ concatMap namesIn (map snd ps)) + = (n', t') : insert n t ps + | otherwise = (n,t):(n',t'):ps + diff --git a/src/Core/Typecheck.hs b/src/Core/Typecheck.hs new file mode 100644 --- /dev/null +++ b/src/Core/Typecheck.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, + PatternGuards #-} + +module Core.Typecheck where + +import Control.Monad.State +import Debug.Trace + +import Core.TT +import Core.Evaluate + +-- To check conversion, normalise each term wrt the current environment. +-- Since we haven't converted everything to de Bruijn indices yet, we'll have to +-- deal with alpha conversion - we do this by making each inner term de Bruijn +-- indexed with 'finalise' + +convertsC :: Context -> Env -> Term -> Term -> StateT UCs TC () +convertsC ctxt env x y + = do c <- convEq (finalise (normalise ctxt env x)) + (finalise (normalise ctxt env y)) + if c then return () + else fail ("Can't convert between " ++ + showEnv env (finalise (normalise ctxt env x)) ++ " and " ++ + showEnv env (finalise (normalise ctxt env y))) + +converts :: Context -> Env -> Term -> Term -> TC () +converts ctxt env x y = if (finalise (normalise ctxt env x) == + finalise (normalise ctxt env y)) + then return () + else fail ("Can't convert between " ++ + showEnvDbg env (finalise (normalise ctxt env x)) ++ " and " ++ + showEnvDbg env (finalise (normalise ctxt env y))) + +isSet :: Context -> Env -> Term -> TC () +isSet ctxt env tm = isSet' (normalise ctxt env tm) + where isSet' (Set _) = return () + isSet' tm = fail (showEnv env tm ++ " is not a Set") + +recheck :: Context -> Env -> Raw -> Term -> TC (Term, Type, UCs) +recheck ctxt env tm orig + = let v = next_tvar ctxt in + case runStateT (check' False ctxt env tm) (v, []) of -- holes banned + Error (IncompleteTerm _) -> Error $ IncompleteTerm orig + Error e -> Error e + OK ((tm, ty), constraints) -> + return (tm, ty, constraints) + +check :: Context -> Env -> Raw -> TC (Term, Type) +check ctxt env tm = evalStateT (check' True ctxt env tm) (0, []) -- Holes allowed + +check' :: Bool -> Context -> Env -> Raw -> StateT UCs TC (Term, Type) +check' holes ctxt env top = chk env top where + chk env (Var n) + | Just (i, ty) <- lookupTyEnv n env = return (P Bound n ty, ty) + | (P nt n' ty : _) <- lookupP Nothing n ctxt = return (P nt n' ty, ty) + | otherwise = do fail $ "No such variable " ++ show n ++ " in " ++ show (map fst env) + chk env (RApp f a) + = do (fv, fty) <- chk env f + (av, aty) <- chk env a + let fty' = renameBinders 0 $ normalise ctxt env fty + case fty' of + Bind x (Pi s) t -> + do convertsC ctxt env aty s + let apty = normalise initContext env (Bind x (Let aty av) t) + return (App fv av, apty) + t -> fail "Can't apply a non-function type" + -- This rather unpleasant hack is needed because during incomplete + -- proofs, variables are locally bound with an explicit name. If we just + -- make sure bound names in function types are locally unique, machine + -- generated names, we'll be fine. + where renameBinders i (Bind x (Pi s) t) = Bind (MN i "binder") (Pi s) + (renameBinders (i+1) t) + renameBinders i sc = sc + chk env RSet + | holes = return (Set (UVal 0), Set (UVal 0)) + | otherwise = do (v, cs) <- get + let c = ULT (UVar v) (UVar (v+1)) + put (v+2, (c:cs)) + return (Set (UVar v), Set (UVar (v+1))) + chk env (RConstant Forgot) = return (Erased, Erased) + chk env (RConstant c) = return (Constant c, constType c) + where constType (I _) = Constant IType + constType (BI _) = Constant BIType + constType (Fl _) = Constant FlType + constType (Ch _) = Constant ChType + constType (Str _) = Constant StrType + constType Forgot = Erased + constType _ = Set (UVal 0) + chk env (RForce t) = do (_, ty) <- chk env t + return (Erased, ty) + chk env (RBind n (Pi s) t) + = do (sv, st) <- chk env s + (tv, tt) <- chk ((n, Pi sv) : env) t + (v, cs) <- get + let Set su = normalise ctxt env st + let Set tu = normalise ctxt env tt + when (not holes) $ put (v+1, ULE su (UVar v):ULE tu (UVar v):cs) + return (Bind n (Pi sv) (pToV n tv), Set (UVar v)) + chk env (RBind n b sc) + = do b' <- checkBinder b + (scv, sct) <- chk ((n, b'):env) sc + discharge n b' (pToV n scv) (pToV n sct) + where checkBinder (Lam t) + = do (tv, tt) <- chk env t + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + lift $ isSet ctxt env tt' + return (Lam tv) + checkBinder (Pi t) + = do (tv, tt) <- chk env t + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + lift $ isSet ctxt env tt' + return (Pi tv) + checkBinder (Let t v) + = do (tv, tt) <- chk env t + (vv, vt) <- chk env v + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + convertsC ctxt env vt tv + lift $ isSet ctxt env tt' + return (Let tv vv) + checkBinder (NLet t v) + = do (tv, tt) <- chk env t + (vv, vt) <- chk env v + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + convertsC ctxt env vt tv + lift $ isSet ctxt env tt' + return (NLet tv vv) + checkBinder (Hole t) + | not holes = lift $ tfail (IncompleteTerm undefined) + | otherwise + = do (tv, tt) <- chk env t + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + lift $ isSet ctxt env tt' + return (Hole tv) + checkBinder (GHole t) + = do (tv, tt) <- chk env t + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + lift $ isSet ctxt env tt' + return (GHole tv) + checkBinder (Guess t v) + | not holes = lift $ tfail (IncompleteTerm undefined) + | otherwise + = do (tv, tt) <- chk env t + (vv, vt) <- chk env v + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + convertsC ctxt env vt tv + lift $ isSet ctxt env tt' + return (Guess tv vv) + checkBinder (PVar t) + = do (tv, tt) <- chk env t + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + lift $ isSet ctxt env tt' + return (PVar tv) + checkBinder (PVTy t) + = do (tv, tt) <- chk env t + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + lift $ isSet ctxt env tt' + return (PVTy tv) + + discharge n (Lam t) scv sct + = return (Bind n (Lam t) scv, Bind n (Pi t) sct) + discharge n (Pi t) scv sct + = return (Bind n (Pi t) scv, sct) + discharge n (Let t v) scv sct + = return (Bind n (Let t v) scv, Bind n (Let t v) sct) + discharge n (NLet t v) scv sct + = return (Bind n (NLet t v) scv, Bind n (Let t v) sct) + discharge n (Hole t) scv sct + = do -- A hole can't appear in the type of its scope + checkNotHoley 0 sct + return (Bind n (Hole t) scv, sct) + discharge n (GHole t) scv sct + = do -- A hole can't appear in the type of its scope + checkNotHoley 0 sct + return (Bind n (GHole t) scv, sct) + discharge n (Guess t v) scv sct + = do -- A hole can't appear in the type of its scope + checkNotHoley 0 sct + return (Bind n (Guess t v) scv, sct) + discharge n (PVar t) scv sct + = return (Bind n (PVar t) scv, Bind n (PVTy t) sct) + discharge n (PVTy t) scv sct + = return (Bind n (PVTy t) scv, sct) + + checkNotHoley i (V v) + | v == i = fail "You can't put a hole where a hole don't belong" + checkNotHoley i (App f a) = do checkNotHoley i f + checkNotHoley i a + checkNotHoley i (Bind n b sc) = checkNotHoley (i+1) sc + checkNotHoley _ _ = return () + + +checkProgram :: Context -> RProgram -> TC Context +checkProgram ctxt [] = return ctxt +checkProgram ctxt ((n, RConst t) : xs) + = do (t', tt') <- trace (show n) $ check ctxt [] t + isSet ctxt [] tt' + checkProgram (addTyDecl n t' ctxt) xs +checkProgram ctxt ((n, RFunction (RawFun ty val)) : xs) + = do (ty', tyt') <- trace (show n) $ check ctxt [] ty + (val', valt') <- check ctxt [] val + isSet ctxt [] tyt' + converts ctxt [] ty' valt' + checkProgram (addToCtxt n val' ty' ctxt) xs +checkProgram ctxt ((n, RData (RDatatype _ ty cons)) : xs) + = do (ty', tyt') <- trace (show n) $ check ctxt [] ty + isSet ctxt [] tyt' + -- add the tycon temporarily so we can check constructors + let ctxt' = addDatatype (Data n 0 ty' []) ctxt + cons' <- mapM (checkCon ctxt') cons + checkProgram (addDatatype (Data n 0 ty' cons') ctxt) xs + where checkCon ctxt (n, cty) = do (cty', ctyt') <- check ctxt [] cty + return (n, cty') + + diff --git a/src/Core/Unify.hs b/src/Core/Unify.hs new file mode 100644 --- /dev/null +++ b/src/Core/Unify.hs @@ -0,0 +1,137 @@ +module Core.Unify(unify, Fails) where + +import Core.TT +import Core.Evaluate + +import Control.Monad +import Control.Monad.State +import Debug.Trace + +-- Unification is applied inside the theorem prover. We're looking for holes +-- which can be filled in, by matching one term's normal form against another. +-- Returns a list of hole names paired with the term which solves them, and +-- a list of things which need to be injective. + +-- terms which need to be injective, with the things we're trying to unify +-- at the time + +type Injs = [(TT Name, TT Name, TT Name)] +type Fails = [(TT Name, TT Name, Env, Err)] + +data UInfo = UI Int Injs Fails + +unify :: Context -> Env -> TT Name -> TT Name -> TC ([(Name, TT Name)], + Injs, Fails) +unify ctxt env topx topy + = case runStateT + (un' False [] (normalise ctxt env topx) (normalise ctxt env topy)) + (UI 0 [] []) of + OK (v, UI _ inj fails) -> return (filter notTrivial v, inj, reverse fails) +-- OK (_, UI s _ ((_,_,f):fs)) -> tfail $ CantUnify topx topy f s + Error e -> tfail e + where + notTrivial (x, P _ x' _) = x /= x' + notTrivial _ = True + + injective (P (DCon _ _) _ _) = True + injective (P (TCon _ _) _ _) = True + injective (App f a) = injective f + injective _ = False + + notP (P _ _ _) = False + notP _ = True + + sc i = do UI s x f <- get + put (UI (s+i) x f) + + uplus u1 u2 = do UI s i f <- get + r <- u1 + UI s _ f' <- get + if (length f == length f') + then return r + else do put (UI s i f); u2 + + un' :: Bool -> [(Name, Name)] -> TT Name -> TT Name -> + StateT UInfo + TC [(Name, TT Name)] + un' fn bnames (P Bound x _) (P Bound y _) + | (x,y) `elem` bnames = do sc 1; return [] + un' fn bnames (P Bound x _) tm + | holeIn env x = do UI s i f <- get + when (notP tm && fn) $ put (UI s ((tm, topx, topy) : i) f) + sc 1 + return [(x, tm)] + un' fn bnames tm (P Bound y _) + | holeIn env y = do UI s i f <- get + when (notP tm && fn) $ put (UI s ((tm, topx, topy) : i) f) + sc 1 + return [(y, tm)] + un' fn bnames (V i) (P Bound x _) + | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] + un' fn bnames (P Bound x _) (V i) + | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] + + un' fn bnames (App fx ax) (App fy ay) + = do uplus -- do the second one if the first adds any errors + (do hf <- un' True bnames fx fy + let ax' = normalise ctxt env (substNames hf ax) + let ay' = normalise ctxt env (substNames hf ay) + ha <- un' False bnames ax' ay' + sc 1 + combine bnames hf ha) + (do ha <- un' False bnames ax ay + let fx' = normalise ctxt env (substNames ha fx) + let fy' = normalise ctxt env (substNames ha fy) + hf <- un' False bnames fx' fy' + sc 1 + combine bnames hf ha) + + un' fn bnames x (Bind n (Lam t) (App y (P Bound n' _))) + | n == n' = un' False bnames x y + un' fn bnames (Bind n (Lam t) (App x (P Bound n' _))) y + | n == n' = un' False bnames x y + un' fn bnames (Bind x bx sx) (Bind y by sy) + = do h1 <- uB bnames bx by + h2 <- un' False ((x,y):bnames) sx sy + combine bnames h1 h2 + un' fn bnames x y + | x == y = do sc 1; return [] + | otherwise = do UI s i f <- get + let err = CantUnify topx topy (CantUnify x y (Msg "") s) s + put (UI s i ((x, y, env, err) : f)) + return [] -- lift $ tfail err + + uB bnames (Let tx vx) (Let ty vy) + = do h1 <- un' False bnames tx ty + h2 <- un' False bnames ty vy + sc 1 + combine bnames h1 h2 + uB bnames (Guess tx vx) (Guess ty vy) + = do h1 <- un' False bnames tx ty + h2 <- un' False bnames ty vy + sc 1 + combine bnames h1 h2 + uB bnames (Lam tx) (Lam ty) = do sc 1; un' False bnames tx ty + uB bnames (Pi tx) (Pi ty) = do sc 1; un' False bnames tx ty + uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty + uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty + uB bnames x y = do UI s i f <- get + let err = CantUnify topx topy + (CantUnify (binderTy x) (binderTy y) (Msg "") s) + s + put (UI s i ((binderTy x, binderTy y, env, err) : f)) + return [] -- lift $ tfail err + + combine bnames as [] = return as + combine bnames as ((n, t) : bs) + = case lookup n as of + Nothing -> combine bnames (as ++ [(n,t)]) bs + Just t' -> do un' False bnames t t' + sc 1 + combine bnames as bs + +holeIn :: Env -> Name -> Bool +holeIn env n = case lookup n env of + Just (Hole _) -> True + _ -> False + diff --git a/src/Idris/AbsSyntax.hs b/src/Idris/AbsSyntax.hs new file mode 100644 --- /dev/null +++ b/src/Idris/AbsSyntax.hs @@ -0,0 +1,1319 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, + TypeSynonymInstances, PatternGuards #-} + +module Idris.AbsSyntax where + +import Core.TT +import Core.Evaluate +import Core.Elaborate +import Core.Typecheck + +import System.Console.Haskeline +import Control.Monad.State +import Data.List +import Data.Char +import Data.Either +import Debug.Trace + +import qualified Epic.Epic as E + +data IOption = IOption { opt_logLevel :: Int, + opt_typecase :: Bool, + opt_typeintype :: Bool, + opt_coverage :: Bool, + opt_showimp :: Bool, + opt_repl :: Bool, + opt_verbose :: Bool + } + deriving (Show, Eq) + +defaultOpts = IOption 0 False False True False True True + +-- TODO: Add 'module data' to IState, which can be saved out and reloaded quickly (i.e +-- without typechecking). +-- This will include all the functions and data declarations, plus fixity declarations +-- and syntax macros. + +data IState = IState { tt_ctxt :: Context, + idris_constraints :: [(UConstraint, FC)], + idris_infixes :: [FixDecl], + idris_implicits :: Ctxt [PArg], + idris_statics :: Ctxt [Bool], + idris_classes :: Ctxt ClassInfo, + idris_optimisation :: Ctxt OptInfo, + idris_datatypes :: Ctxt TypeInfo, + idris_patdefs :: Ctxt [(Term, Term)], -- not exported + idris_log :: String, + idris_options :: IOption, + idris_name :: Int, + idris_metavars :: [Name], + syntax_rules :: [Syntax], + syntax_keywords :: [String], + imported :: [FilePath], + idris_prims :: [(Name, ([E.Name], E.Term))], + idris_objs :: [FilePath], + idris_libs :: [String], + idris_hdrs :: [String], + last_proof :: Maybe (Name, [String]), + errLine :: Maybe Int, + lastParse :: Maybe Name, + indent_stack :: [Int], + brace_stack :: [Maybe Int], + hide_list :: [(Name, Maybe Accessibility)], + default_access :: Accessibility, + ibc_write :: [IBCWrite], + compiled_so :: Maybe String + } + +-- information that needs writing for the current module's .ibc file +data IBCWrite = IBCFix FixDecl + | IBCImp Name + | IBCStatic Name + | IBCClass Name + | IBCData Name + | IBCOpt Name + | IBCSyntax Syntax + | IBCKeyword String + | IBCImport FilePath + | IBCObj FilePath + | IBCLib String + | IBCHeader String + | IBCAccess Name Accessibility + | IBCDef Name -- i.e. main context + deriving Show + +idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext + emptyContext emptyContext emptyContext + "" defaultOpts 6 [] [] [] [] [] [] [] [] + Nothing Nothing Nothing [] [] [] Hidden [] Nothing + +-- The monad for the main REPL - reading and processing files and updating +-- global state (hence the IO inner monad). +type Idris = StateT IState (InputT IO) + +getContext :: Idris Context +getContext = do i <- get; return (tt_ctxt i) + +getObjectFiles :: Idris [FilePath] +getObjectFiles = do i <- get; return (idris_objs i) + +addObjectFile :: FilePath -> Idris () +addObjectFile f = do i <- get; put (i { idris_objs = f : idris_objs i }) + +getLibs :: Idris [String] +getLibs = do i <- get; return (idris_libs i) + +addLib :: String -> Idris () +addLib f = do i <- get; put (i { idris_libs = f : idris_libs i }) + +addHdr :: String -> Idris () +addHdr f = do i <- get; put (i { idris_hdrs = f : idris_hdrs i }) + +setAccessibility :: Name -> Accessibility -> Idris () +setAccessibility n a + = do i <- get + let ctxt = setAccess n a (tt_ctxt i) + put (i { tt_ctxt = ctxt }) + +addIBC :: IBCWrite -> Idris () +addIBC ibc@(IBCDef n) + = do i <- get + when (notDef (ibc_write i)) $ + put (i { ibc_write = ibc : ibc_write i }) + where notDef [] = True + notDef (IBCDef n': is) | n == n' = False + notDef (_ : is) = notDef is +addIBC ibc = do i <- get; put (i { ibc_write = ibc : ibc_write i }) + +clearIBC :: Idris () +clearIBC = do i <- get; put (i { ibc_write = [] }) + +getHdrs :: Idris [String] +getHdrs = do i <- get; return (idris_hdrs i) + +setErrLine :: Int -> Idris () +setErrLine x = do i <- get; + case (errLine i) of + Nothing -> put (i { errLine = Just x }) + Just _ -> return () + +clearErr :: Idris () +clearErr = do i <- get + put (i { errLine = Nothing }) + +getSO :: Idris (Maybe String) +getSO = do i <- get + return (compiled_so i) + +setSO :: Maybe String -> Idris () +setSO s = do i <- get + put (i { compiled_so = s }) + +getIState :: Idris IState +getIState = get + +putIState :: IState -> Idris () +putIState = put + +getName :: Idris Int +getName = do i <- get; + let idx = idris_name i; + put (i { idris_name = idx + 1 }) + return idx + +checkUndefined :: FC -> Name -> Idris () +checkUndefined fc n + = do i <- getContext + case lookupTy Nothing n i of + (_:_) -> fail $ show fc ++ ":" ++ + show n ++ " already defined" + _ -> return () + +setContext :: Context -> Idris () +setContext ctxt = do i <- get; put (i { tt_ctxt = ctxt } ) + +updateContext :: (Context -> Context) -> Idris () +updateContext f = do i <- get; put (i { tt_ctxt = f (tt_ctxt i) } ) + +addConstraints :: FC -> (Int, [UConstraint]) -> Idris () +addConstraints fc (v, cs) + = do i <- get + let ctxt = tt_ctxt i + let ctxt' = ctxt { uconstraints = cs ++ uconstraints ctxt, + next_tvar = v } + let ics = zip cs (repeat fc) ++ idris_constraints i + put (i { tt_ctxt = ctxt', idris_constraints = ics }) + +addDeferred :: [(Name, Type)] -> Idris () +addDeferred ns = do mapM_ (\(n, t) -> updateContext (addTyDecl n (tidyNames [] t))) ns + i <- get + put (i { idris_metavars = map fst ns ++ idris_metavars i }) + where tidyNames used (Bind (MN i x) b sc) + = let n' = uniqueName (UN x) used in + Bind n' b $ tidyNames (n':used) sc + tidyNames used (Bind n b sc) + = let n' = uniqueName n used in + Bind n' b $ tidyNames (n':used) sc + tidyNames used b = b + +solveDeferred :: Name -> Idris () +solveDeferred n = do i <- get + put (i { idris_metavars = idris_metavars i \\ [n] }) + +iputStrLn :: String -> Idris () +iputStrLn = liftIO . putStrLn + +iWarn :: FC -> String -> Idris () +iWarn fc err = liftIO $ putStrLn (show fc ++ ":" ++ err) + +setLogLevel :: Int -> Idris () +setLogLevel l = do i <- get + let opts = idris_options i + let opt' = opts { opt_logLevel = l } + put (i { idris_options = opt' } ) + +logLevel :: Idris Int +logLevel = do i <- get + return (opt_logLevel (idris_options i)) + +useREPL :: Idris Bool +useREPL = do i <- get + return (opt_repl (idris_options i)) + +setREPL :: Bool -> Idris () +setREPL t = do i <- get + let opts = idris_options i + let opt' = opts { opt_repl = t } + put (i { idris_options = opt' }) + +verbose :: Idris Bool +verbose = do i <- get + return (opt_verbose (idris_options i)) + +setVerbose :: Bool -> Idris () +setVerbose t = do i <- get + let opts = idris_options i + let opt' = opts { opt_verbose = t } + put (i { idris_options = opt' }) + +typeInType :: Idris Bool +typeInType = do i <- get + return (opt_typeintype (idris_options i)) + +setTypeInType :: Bool -> Idris () +setTypeInType t = do i <- get + let opts = idris_options i + let opt' = opts { opt_typeintype = t } + put (i { idris_options = opt' }) + +coverage :: Idris Bool +coverage = do i <- get + return (opt_coverage (idris_options i)) + +setCoverage :: Bool -> Idris () +setCoverage t = do i <- get + let opts = idris_options i + let opt' = opts { opt_coverage = t } + put (i { idris_options = opt' }) + +impShow :: Idris Bool +impShow = do i <- get + return (opt_showimp (idris_options i)) + +setImpShow :: Bool -> Idris () +setImpShow t = do i <- get + let opts = idris_options i + let opt' = opts { opt_showimp = t } + put (i { idris_options = opt' }) + +logLvl :: Int -> String -> Idris () +logLvl l str = do i <- get + let lvl = opt_logLevel (idris_options i) + when (lvl >= l) + $ do liftIO (putStrLn str) + put (i { idris_log = idris_log i ++ str ++ "\n" } ) + +iLOG :: String -> Idris () +iLOG = logLvl 1 + +noErrors :: Idris Bool +noErrors = do i <- get + case errLine i of + Nothing -> return True + _ -> return False + +setTypeCase :: Bool -> Idris () +setTypeCase t = do i <- get + let opts = idris_options i + let opt' = opts { opt_typecase = t } + put (i { idris_options = opt' }) + +-- Commands in the REPL + +data Command = Quit | Help | Eval PTerm | Check PTerm | Reload | Edit + | Compile String | Execute | ExecVal PTerm + | Metavars | Prove Name | AddProof | Universes + | TTShell + | LogLvl Int | Spec PTerm | HNF PTerm | Defn Name | Info Name + | NOP + +-- Parsed declarations + +data Fixity = Infixl { prec :: Int } + | Infixr { prec :: Int } + | InfixN { prec :: Int } + | PrefixN { prec :: Int } + deriving Eq +{-! +deriving instance Binary Fixity +!-} + +instance Show Fixity where + show (Infixl i) = "infixl " ++ show i + show (Infixr i) = "infixr " ++ show i + show (InfixN i) = "infix " ++ show i + show (PrefixN i) = "prefix " ++ show i + +data FixDecl = Fix Fixity String + deriving (Show, Eq) +{-! +deriving instance Binary FixDecl +!-} + +instance Ord FixDecl where + compare (Fix x _) (Fix y _) = compare (prec x) (prec y) + + +data Static = Static | Dynamic + deriving (Show, Eq) +{-! +deriving instance Binary Static +!-} + +-- Mark bindings with their explicitness, and laziness +data Plicity = Imp { plazy :: Bool, + pstatic :: Static } + | Exp { plazy :: Bool, + pstatic :: Static } + | Constraint { plazy :: Bool, + pstatic :: Static } + deriving (Show, Eq) + +{-! +deriving instance Binary Plicity +!-} + +impl = Imp False Dynamic +expl = Exp False Dynamic +constraint = Constraint False Static + +data FnOpt = Inlinable | Partial | Abstract | Private | TCGen + deriving (Show, Eq) + +type FnOpts = [FnOpt] + +inlinable :: FnOpts -> Bool +inlinable = elem Inlinable + +data PDecl' t = PFix FC Fixity [String] -- fixity declaration + | PTy SyntaxInfo FC Name t -- type declaration + | PClauses FC FnOpts Name [PClause' t] -- pattern clause + | PData SyntaxInfo FC (PData' t) -- data declaration + | PParams FC [(Name, t)] [PDecl' t] -- params block + | PNamespace String [PDecl' t] -- new namespace + | PClass SyntaxInfo FC + [t] -- constraints + Name + [(Name, t)] -- parameters + [PDecl' t] -- declarations + | PInstance SyntaxInfo FC [t] -- constraints + Name -- class + [t] -- parameters + t -- full instance type + [PDecl' t] + | PSyntax FC Syntax + | PDirective (Idris ()) + deriving Functor + +data PClause' t = PClause Name t [t] t [PDecl' t] + | PWith Name t [t] t [PDecl' t] + | PClauseR [t] t [PDecl' t] + | PWithR [t] t [PDecl' t] + deriving Functor + +data PData' t = PDatadecl { d_name :: Name, + d_tcon :: t, + d_cons :: [(Name, t, FC)] } + deriving Functor + +-- Handy to get a free function for applying PTerm -> PTerm functions +-- across a program, by deriving Functor + +type PDecl = PDecl' PTerm +type PData = PData' PTerm +type PClause = PClause' PTerm + +-- get all the names declared in a decl + +declared :: PDecl -> [Name] +declared (PFix _ _ _) = [] +declared (PTy _ _ n t) = [n] +declared (PClauses _ _ n _) = [] -- not a declaration +declared (PData _ _ (PDatadecl n _ ts)) = n : map fstt ts + where fstt (a, _, _) = a +declared (PParams _ _ ds) = concatMap declared ds +declared (PNamespace _ ds) = concatMap declared ds +-- declared (PImport _) = [] + +updateN :: [(Name, Name)] -> Name -> Name +updateN ns n | Just n' <- lookup n ns = n' +updateN _ n = n + +updateNs :: [(Name, Name)] -> PTerm -> PTerm +updateNs [] t = t +updateNs ns t = mapPT updateRef t + where updateRef (PRef fc f) = PRef fc (updateN ns f) + updateRef t = t + +-- updateDNs :: [(Name, Name)] -> PDecl -> PDecl +-- updateDNs [] t = t +-- updateDNs ns (PTy s f n t) | Just n' <- lookup n ns = PTy s f n' t +-- updateDNs ns (PClauses f n c) | Just n' <- lookup n ns = PClauses f n' (map updateCNs c) +-- where updateCNs ns (PClause n l ts r ds) +-- = PClause (updateN ns n) (fmap (updateNs ns) l) +-- (map (fmap (updateNs ns)) ts) +-- (fmap (updateNs ns) r) +-- (map (updateDNs ns) ds) +-- updateDNs ns c = c + +-- High level language terms + +data PTerm = PQuote Raw + | PRef FC Name + | PLam Name PTerm PTerm + | PPi Plicity Name PTerm PTerm + | PLet Name PTerm PTerm PTerm + | PApp FC PTerm [PArg] + | PCase FC PTerm [(PTerm, PTerm)] + | PTrue FC + | PFalse FC + | PRefl FC + | PResolveTC FC + | PEq FC PTerm PTerm + | PPair FC PTerm PTerm + | PDPair FC PTerm PTerm PTerm + | PAlternative [PTerm] + | PHidden PTerm -- irrelevant or hidden pattern + | PSet + | PConstant Const + | Placeholder + | PDoBlock [PDo] + | PIdiom FC PTerm + | PReturn FC + | PMetavar Name + | PProof [PTactic] + | PTactics [PTactic] -- as PProof, but no auto solving + | PElabError String -- error to report on elaboration + | PImpossible -- special case for declaring when an LHS can't typecheck + deriving Eq +{-! +deriving instance Binary PTerm +!-} + +mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm +mapPT f t = f (mpt t) where + mpt (PLam n t s) = PLam n (mapPT f t) (mapPT f s) + mpt (PPi p n t s) = PPi p n (mapPT f t) (mapPT f s) + mpt (PLet n ty v s) = PLet n (mapPT f ty) (mapPT f v) (mapPT f s) + mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as) + mpt (PCase fc c os) = PCase fc (mapPT f c) (map (pmap (mapPT f)) os) + mpt (PEq fc l r) = PEq fc (mapPT f l) (mapPT f r) + mpt (PPair fc l r) = PPair fc (mapPT f l) (mapPT f r) + mpt (PDPair fc l t r) = PDPair fc (mapPT f l) (mapPT f t) (mapPT f r) + mpt (PAlternative as) = PAlternative (map (mapPT f) as) + mpt (PHidden t) = PHidden (mapPT f t) + mpt (PDoBlock ds) = PDoBlock (map (fmap (mapPT f)) ds) + mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts) + mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts) + mpt x = x + + +data PTactic' t = Intro [Name] | Intros | Focus Name + | Refine Name [Bool] | Rewrite t | LetTac Name t + | Exact t | Compute | Trivial + | Solve + | Attack + | ProofState | ProofTerm | Undo + | Try (PTactic' t) (PTactic' t) + | TSeq (PTactic' t) (PTactic' t) + | Qed + deriving (Show, Eq, Functor) +{-! +deriving instance Binary PTactic' +!-} + +type PTactic = PTactic' PTerm + +data PDo' t = DoExp FC t + | DoBind FC Name t + | DoBindP FC t t + | DoLet FC Name t t + | DoLetP FC t t + deriving (Eq, Functor) +{-! +deriving instance Binary PDo' +!-} + +type PDo = PDo' PTerm + +-- The priority gives a hint as to elaboration order. Best to elaborate +-- things early which will help give a more concrete type to other +-- variables, e.g. a before (interpTy a). + +data PArg' t = PImp { priority :: Int, + lazyarg :: Bool, pname :: Name, getTm :: t } + | PExp { priority :: Int, + lazyarg :: Bool, getTm :: t } + | PConstraint { priority :: Int, + lazyarg :: Bool, getTm :: t } + deriving (Show, Eq, Functor) +{-! +deriving instance Binary PArg' +!-} + +pimp = PImp 0 True +pexp = PExp 0 False +pconst = PConstraint 0 False + +type PArg = PArg' PTerm + +-- Type class data + +data ClassInfo = CI { instanceName :: Name, + class_methods :: [(Name, PTerm)], + class_defaults :: [(Name, Name)], -- method name -> default impl + class_params :: [Name] } + deriving Show +{-! +deriving instance Binary ClassInfo +!-} + +data OptInfo = Optimise { collapsible :: Bool, + forceable :: [Int], -- argument positions + recursive :: [Int] } + deriving Show +{-! +deriving instance Binary OptInfo +!-} + + +data TypeInfo = TI { con_names :: [Name] } + deriving Show +{-! +deriving instance Binary TypeInfo +!-} + +-- Syntactic sugar info + +data DSL = DSL { dsl_bind :: PTerm, + dsl_return :: PTerm, + dsl_apply :: PTerm, + dsl_pure :: PTerm, + index_first :: Maybe PTerm, + index_next :: Maybe PTerm, + dsl_lambda :: Maybe PTerm, + dsl_let :: Maybe PTerm + } + deriving Show + +data SynContext = PatternSyntax | TermSyntax | AnySyntax + deriving Show +{-! +deriving instance Binary SynContext +!-} + +data Syntax = Rule [SSymbol] PTerm SynContext + deriving Show +{-! +deriving instance Binary Syntax +!-} + +data SSymbol = Keyword Name + | Symbol String + | Expr Name + deriving Show +{-! +deriving instance Binary SSymbol +!-} + +initDSL = DSL (PRef f (UN ">>=")) + (PRef f (UN "return")) + (PRef f (UN "<$>")) + (PRef f (UN "pure")) + Nothing + Nothing + Nothing + Nothing + where f = FC "(builtin)" 0 + +data SyntaxInfo = Syn { using :: [(Name, PTerm)], + syn_params :: [(Name, PTerm)], + syn_namespace :: [String], + no_imp :: [Name], + decoration :: Name -> Name, + inPattern :: Bool, + dsl_info :: DSL } + deriving Show + +defaultSyntax = Syn [] [] [] [] id False initDSL + +--- Pretty printing declarations and terms + +instance Show PTerm where + show tm = showImp False tm + +instance Show PDecl where + show (PFix _ f ops) = show f ++ " " ++ showSep ", " ops + show (PTy _ _ n ty) = show n ++ " : " ++ show ty + show (PClauses _ _ n c) = showSep "\n" (map show c) + show (PData _ _ d) = show d + +instance Show PClause where + show c = showCImp True c + +instance Show PData where + show d = showDImp False d + +showCImp :: Bool -> PClause -> String +showCImp impl (PClause n l ws r w) + = showImp impl l ++ showWs ws ++ " = " ++ showImp impl r + ++ " where " ++ show w + where + showWs [] = "" + showWs (x : xs) = " | " ++ showImp impl x ++ showWs xs +showCImp impl (PWith n l ws r w) + = showImp impl l ++ showWs ws ++ " with " ++ showImp impl r + ++ " { " ++ show w ++ " } " + where + showWs [] = "" + showWs (x : xs) = " | " ++ showImp impl x ++ showWs xs + + +showDImp :: Bool -> PData -> String +showDImp impl (PDatadecl n ty cons) + = "data " ++ show n ++ " : " ++ showImp impl ty ++ " where\n\t" + ++ showSep "\n\t| " + (map (\ (n, t, _) -> show n ++ " : " ++ showImp impl t) cons) + +getImps :: [PArg] -> [(Name, PTerm)] +getImps [] = [] +getImps (PImp _ _ n tm : xs) = (n, tm) : getImps xs +getImps (_ : xs) = getImps xs + +getExps :: [PArg] -> [PTerm] +getExps [] = [] +getExps (PExp _ _ tm : xs) = tm : getExps xs +getExps (_ : xs) = getExps xs + +getConsts :: [PArg] -> [PTerm] +getConsts [] = [] +getConsts (PConstraint _ _ tm : xs) = tm : getConsts xs +getConsts (_ : xs) = getConsts xs + +getAll :: [PArg] -> [PTerm] +getAll = map getTm + +showImp :: Bool -> PTerm -> String +showImp impl tm = se 10 tm where + se p (PQuote r) = "![" ++ show r ++ "]" + se p (PRef _ n) = if impl then show n + else showbasic n + where showbasic n@(UN _) = show n + showbasic (MN _ s) = s + showbasic (NS n s) = showSep "." (reverse s) ++ "." ++ showbasic n + se p (PLam n ty sc) = bracket p 2 $ "\\ " ++ show n ++ " => " ++ show sc + se p (PLet n ty v sc) = bracket p 2 $ "let " ++ show n ++ " = " ++ se 10 v ++ + " in " ++ se 10 sc + se p (PPi (Exp l s) n ty sc) + | n `elem` allNamesIn sc = bracket p 2 $ + if l then "|(" else "(" ++ + show n ++ " : " ++ se 10 ty ++ + ") " ++ st ++ + "-> " ++ se 10 sc + | otherwise = bracket p 2 $ se 0 ty ++ " " ++ st ++ "-> " ++ se 10 sc + where st = case s of + Static -> "[static] " + _ -> "" + se p (PPi (Imp l s) n ty sc) + | impl = bracket p 2 $ if l then "|{" else "{" ++ + show n ++ " : " ++ se 10 ty ++ + "} " ++ st ++ "-> " ++ se 10 sc + | otherwise = se 10 sc + where st = case s of + Static -> "[static] " + _ -> "" + se p (PPi (Constraint _ _) n ty sc) + = bracket p 2 $ se 10 ty ++ " => " ++ se 10 sc + se p (PApp _ (PRef _ f) []) + | not impl = show f + se p (PApp _ (PRef _ op@(UN (f:_))) args) + | length (getExps args) == 2 && not impl && not (isAlpha f) + = let [l, r] = getExps args in + bracket p 1 $ se 1 l ++ " " ++ show op ++ " " ++ se 0 r + se p (PApp _ f as) + = let args = getExps as in + bracket p 1 $ se 1 f ++ if impl then concatMap sArg as + else concatMap seArg args + se p (PCase _ scr opts) = "case " ++ se 10 scr ++ " of " ++ showSep " | " (map sc opts) + where sc (l, r) = se 10 l ++ " => " ++ se 10 r + se p (PHidden tm) = "." ++ se 0 tm + se p (PRefl _) = "refl" + se p (PResolveTC _) = "resolvetc" + se p (PTrue _) = "()" + se p (PFalse _) = "_|_" + se p (PEq _ l r) = bracket p 2 $ se 10 l ++ " = " ++ se 10 r + se p (PPair _ l r) = "(" ++ se 10 l ++ ", " ++ se 10 r ++ ")" + se p (PDPair _ l t r) = "(" ++ se 10 l ++ " ** " ++ se 10 r ++ ")" + se p (PAlternative as) = "(|" ++ showSep " , " (map (se 10) as) ++ "|)" + se p PSet = "Set" + se p (PConstant c) = show c + se p (PProof ts) = "proof { " ++ show ts ++ "}" + se p (PTactics ts) = "tactics { " ++ show ts ++ "}" + se p (PMetavar n) = "?" ++ show n + se p (PReturn f) = "return" + se p PImpossible = "impossible" + se p Placeholder = "_" + se p (PDoBlock _) = "do block show not implemented" + se p (PElabError s) = s +-- se p x = "Not implemented" + + sArg (PImp _ _ n tm) = siArg (n, tm) + sArg (PExp _ _ tm) = seArg tm + sArg (PConstraint _ _ tm) = scArg tm + + seArg arg = " " ++ se 0 arg + siArg (n, val) = " {" ++ show n ++ " = " ++ se 10 val ++ "}" + scArg val = " {{" ++ se 10 val ++ "}}" + + bracket outer inner str | inner > outer = "(" ++ str ++ ")" + | otherwise = str + +allNamesIn :: PTerm -> [Name] +allNamesIn tm = nub $ ni [] tm + where + ni env (PRef _ n) + | not (n `elem` env) = [n] + ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) + ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os) + ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc + ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc + ni env (PHidden tm) = ni env tm + ni env (PEq _ l r) = ni env l ++ ni env r + ni env (PPair _ l r) = ni env l ++ ni env r + ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r + ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r + ni env (PAlternative ls) = concatMap (ni env) ls + ni env _ = [] + +namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name] +namesIn uvars ist tm = nub $ ni [] tm + where + ni env (PRef _ n) + | not (n `elem` env) + = case lookupTy Nothing n (tt_ctxt ist) of + [] -> [n] + _ -> if n `elem` (map fst uvars) then [n] else [] + ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) + ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os) + ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc + ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc + ni env (PEq _ l r) = ni env l ++ ni env r + ni env (PPair _ l r) = ni env l ++ ni env r + ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r + ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r + ni env (PAlternative as) = concatMap (ni env) as + ni env (PHidden tm) = ni env tm + ni env _ = [] + +-- For inferring types of things + +bi = FC "builtin" 0 + +inferTy = MN 0 "__Infer" +inferCon = MN 0 "__infer" +inferDecl = PDatadecl inferTy + PSet + [(inferCon, PPi impl (MN 0 "A") PSet ( + PPi expl (MN 0 "a") (PRef bi (MN 0 "A")) + (PRef bi inferTy)), bi)] + +infTerm t = PApp bi (PRef bi inferCon) [pimp (MN 0 "A") Placeholder, pexp t] +infP = P (TCon 6 0) inferTy (Set (UVal 0)) + +getInferTerm, getInferType :: Term -> Term +getInferTerm (Bind n b sc) = Bind n b $ getInferTerm sc +getInferTerm (App (App _ _) tm) = tm +getInferTerm tm = error ("getInferTerm " ++ show tm) + +getInferType (Bind n b sc) = Bind n b $ getInferType sc +getInferType (App (App _ ty) _) = ty + +-- Handy primitives: Unit, False, Pair, MkPair, =, mkForeign + +primNames = [unitTy, unitCon, + falseTy, pairTy, pairCon, + eqTy, eqCon, inferTy, inferCon] + +unitTy = MN 0 "__Unit" +unitCon = MN 0 "__II" +unitDecl = PDatadecl unitTy PSet + [(unitCon, PRef bi unitTy, bi)] + +falseTy = MN 0 "__False" +falseDecl = PDatadecl falseTy PSet [] + +pairTy = MN 0 "__Pair" +pairCon = MN 0 "__MkPair" +pairDecl = PDatadecl pairTy (piBind [(n "A", PSet), (n "B", PSet)] PSet) + [(pairCon, PPi impl (n "A") PSet ( + PPi impl (n "B") PSet ( + PPi expl (n "a") (PRef bi (n "A")) ( + PPi expl (n "b") (PRef bi (n "B")) + (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")), + pexp (PRef bi (n "B"))])))), bi)] + where n a = MN 0 a + +eqTy = UN "=" +eqCon = UN "refl" +eqDecl = PDatadecl eqTy (piBind [(n "a", PSet), (n "b", PSet), + (n "x", PRef bi (n "a")), (n "y", PRef bi (n "b"))] + PSet) + [(eqCon, PPi impl (n "a") PSet ( + PPi impl (n "x") (PRef bi (n "a")) + (PApp bi (PRef bi eqTy) [pimp (n "a") Placeholder, + pimp (n "b") Placeholder, + pexp (PRef bi (n "x")), + pexp (PRef bi (n "x"))])), bi)] + where n a = MN 0 a + +-- Defined in builtins.idr +sigmaTy = UN "Exists" +existsCon = UN "Ex_intro" + +piBind :: [(Name, PTerm)] -> PTerm -> PTerm +piBind [] t = t +piBind ((n, ty):ns) t = PPi expl n ty (piBind ns t) + +tcname (UN ('@':_)) = True +tcname (NS n _) = tcname n +tcname _ = False + +-- Dealing with parameters + +expandParams :: (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PTerm -> PTerm +expandParams dec ps ns tm = en tm + where + -- if we shadow a name (say in a lambda binding) that is used in a call to + -- a lifted function, we need access to both names - once in the scope of the + -- binding and once to call the lifted functions. So we'll explicitly shadow + -- it. (Yes, it's a hack. The alternative would be to resolve names earlier + -- but we didn't...) + + mkShadow (UN n) = MN 0 n + mkShadow (MN i n) = MN (i+1) n + mkShadow (NS x s) = NS (mkShadow x) s + + en (PLam n t s) + | n `elem` map fst ps + = let n' = mkShadow n in + PLam n' (en t) (en (shadow n n' s)) + | otherwise = PLam n (en t) (en s) + en (PPi p n t s) + | n `elem` map fst ps + = let n' = mkShadow n in + PPi p n' (en t) (en (shadow n n' s)) + | otherwise = PPi p n (en t) (en s) + en (PLet n ty v s) + | n `elem` map fst ps + = let n' = mkShadow n in + PLet n' (en ty) (en v) (en (shadow n n' s)) + | otherwise = PLet n (en ty) (en v) (en s) + en (PEq f l r) = PEq f (en l) (en r) + en (PPair f l r) = PPair f (en l) (en r) + en (PDPair f l t r) = PDPair f (en l) (en t) (en r) + en (PAlternative as) = PAlternative (map en as) + en (PHidden t) = PHidden (en t) + en (PDoBlock ds) = PDoBlock (map (fmap en) ds) + en (PProof ts) = PProof (map (fmap en) ts) + en (PTactics ts) = PTactics (map (fmap en) ts) + + en (PQuote (Var n)) + | n `elem` ns = PQuote (Var (dec n)) + en (PApp fc (PRef fc' n) as) + | n `elem` ns = PApp fc (PRef fc' (dec n)) + (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as)) + en (PRef fc n) + | n `elem` ns = PApp fc (PRef fc (dec n)) + (map (pexp . (PRef fc)) (map fst ps)) + en (PApp fc f as) = PApp fc (en f) (map (fmap en) as) + en (PCase fc c os) = PCase fc (en c) (map (pmap en) os) + en t = t + +expandParamsD :: IState -> + (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl +expandParamsD ist dec ps ns (PTy syn fc n ty) + = if n `elem` ns + then PTy syn fc (dec n) (piBind ps (expandParams dec ps ns ty)) + else PTy syn fc n (expandParams dec ps ns ty) +expandParamsD ist dec ps ns (PClauses fc opts n cs) + = let n' = if n `elem` ns then dec n else n in + PClauses fc opts n' (map expandParamsC cs) + where + expandParamsC (PClause n lhs ws rhs ds) + = let -- ps' = updateps True (namesIn ist rhs) (zip ps [0..]) + ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..]) + n' = if n `elem` ns then dec n else n in + PClause n' (expandParams dec ps'' ns lhs) + (map (expandParams dec ps'' ns) ws) + (expandParams dec ps'' ns rhs) + (map (expandParamsD ist dec ps'' ns) ds) + expandParamsC (PWith n lhs ws wval ds) + = let -- ps' = updateps True (namesIn ist wval) (zip ps [0..]) + ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..]) + n' = if n `elem` ns then dec n else n in + PWith n' (expandParams dec ps'' ns lhs) + (map (expandParams dec ps'' ns) ws) + (expandParams dec ps'' ns wval) + (map (expandParamsD ist dec ps'' ns) ds) + updateps yn nm [] = [] + updateps yn nm (((a, t), i):as) + | (a `elem` nm) == yn = (a, t) : updateps yn nm as + | otherwise = (MN i (show n ++ "_u"), t) : updateps yn nm as + +expandParamsD ist dec ps ns d = d + +-- Calculate a priority for a type, for deciding elaboration order +-- * if it's just a type variable or concrete type, do it early (0) +-- * if there's only type variables and injective constructors, do it next (1) +-- * if there's a function type, next (2) +-- * finally, everything else (3) + +getPriority :: IState -> PTerm -> Int +getPriority i tm = pri tm + where + pri (PRef _ n) = + case lookupP Nothing n (tt_ctxt i) of + ((P (DCon _ _) _ _):_) -> 1 + ((P (TCon _ _) _ _):_) -> 1 + ((P Ref _ _):_) -> 4 + [] -> 0 -- must be locally bound, if it's not an error... + pri (PPi _ _ x y) = max 5 (max (pri x) (pri y)) + pri (PTrue _) = 0 + pri (PFalse _) = 0 + pri (PRefl _) = 1 + pri (PEq _ l r) = max 1 (max (pri l) (pri r)) + pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as))) + pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as))) + pri (PPair _ l r) = max 1 (max (pri l) (pri r)) + pri (PDPair _ l t r) = max 1 (max (pri l) (max (pri t) (pri r))) + pri (PAlternative as) = maximum (map pri as) + pri (PConstant _) = 0 + pri Placeholder = 1 + pri _ = 3 + +-- Dealing with implicit arguments + +-- Add implicit Pi bindings for any names in the term which appear in an +-- argument position. + +-- This has become a right mess already. Better redo it some time... + +implicit :: SyntaxInfo -> Name -> PTerm -> Idris PTerm +implicit syn n ptm + = do i <- get + let (tm', impdata) = implicitise syn i ptm + let (tm'', spos) = findStatics i tm' + put (i { idris_implicits = addDef n impdata (idris_implicits i) }) + addIBC (IBCImp n) + logLvl 5 ("Implicit " ++ show n ++ " " ++ show impdata) + i <- get + put (i { idris_statics = addDef n spos (idris_statics i) }) + addIBC (IBCStatic n) + return tm'' + +implicitise :: SyntaxInfo -> IState -> PTerm -> (PTerm, [PArg]) +implicitise syn ist tm + = let (declimps, ns') = execState (imps True [] tm) ([], []) + ns = ns' \\ (map fst pvars ++ no_imp syn) in + if null ns + then (tm, reverse declimps) + else implicitise syn ist (pibind uvars ns tm) + where + uvars = using syn + pvars = syn_params syn + + dropAll (x:xs) ys | x `elem` ys = dropAll xs ys + | otherwise = x : dropAll xs ys + dropAll [] ys = [] + + imps top env (PApp _ f as) + = do (decls, ns) <- get + let isn = concatMap (namesIn uvars ist) (map getTm as) + put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) + imps top env (PPi (Imp l _) n ty sc) + = do let isn = nub (namesIn uvars ist ty) `dropAll` [n] + (decls , ns) <- get + put (PImp (getPriority ist ty) l n ty : decls, + nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) + imps True (n:env) sc + imps top env (PPi (Exp l _) n ty sc) + = do let isn = nub (namesIn uvars ist ty ++ case sc of + (PRef _ x) -> namesIn uvars ist sc `dropAll` [n] + _ -> []) + (decls, ns) <- get -- ignore decls in HO types + put (PExp (getPriority ist ty) l ty : decls, + nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) + imps True (n:env) sc + imps top env (PPi (Constraint l _) n ty sc) + = do let isn = nub (namesIn uvars ist ty ++ case sc of + (PRef _ x) -> namesIn uvars ist sc `dropAll` [n] + _ -> []) + (decls, ns) <- get -- ignore decls in HO types + put (PConstraint 10 l ty : decls, + nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) + imps True (n:env) sc + imps top env (PEq _ l r) + = do (decls, ns) <- get + let isn = namesIn uvars ist l ++ namesIn uvars ist r + put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) + imps top env (PPair _ l r) + = do (decls, ns) <- get + let isn = namesIn uvars ist l ++ namesIn uvars ist r + put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) + imps top env (PDPair _ (PRef _ n) t r) + = do (decls, ns) <- get + let isn = nub (namesIn uvars ist t ++ namesIn uvars ist r) \\ [n] + put (decls, nub (ns ++ (isn \\ (env ++ map fst (getImps decls))))) + imps top env (PDPair _ l t r) + = do (decls, ns) <- get + let isn = namesIn uvars ist l ++ namesIn uvars ist t ++ + namesIn uvars ist r + put (decls, nub (ns ++ (isn \\ (env ++ map fst (getImps decls))))) + imps top env (PAlternative as) + = do (decls, ns) <- get + let isn = concatMap (namesIn uvars ist) as + put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) + imps top env (PLam n ty sc) + = do imps False env ty + imps False (n:env) sc + imps top env (PHidden tm) = imps False env tm + imps top env _ = return () + + pibind using [] sc = sc + pibind using (n:ns) sc + = case lookup n using of + Just ty -> PPi (Imp False Dynamic) n ty (pibind using ns sc) + Nothing -> PPi (Imp False Dynamic) n Placeholder (pibind using ns sc) + +-- Add implicit arguments in function calls + +addImpl :: IState -> PTerm -> PTerm +addImpl ist ptm = ai [] ptm + where + ai env (PRef fc f) + | not (f `elem` env) = aiFn ist fc f [] + ai env (PEq fc l r) = let l' = ai env l + r' = ai env r in + PEq fc l' r' + ai env (PPair fc l r) = let l' = ai env l + r' = ai env r in + PPair fc l' r' + ai env (PDPair fc l t r) = let l' = ai env l + t' = ai env t + r' = ai env r in + PDPair fc l' t' r' + ai env (PAlternative as) = let as' = map (ai env) as in + PAlternative as' + ai env (PApp fc (PRef _ f) as) + | not (f `elem` env) + = let as' = map (fmap (ai env)) as in + aiFn ist fc f as' + ai env (PApp fc f as) = let f' = ai env f + as' = map (fmap (ai env)) as in + mkPApp fc 1 f' as' + ai env (PCase fc c os) = let c' = ai env c + os' = map (pmap (ai env)) os in + PCase fc c' os' + ai env (PLam n ty sc) = let ty' = ai env ty + sc' = ai (n:env) sc in + PLam n ty' sc' + ai env (PLet n ty val sc) + = let ty' = ai env ty + val' = ai env val + sc' = ai (n:env) sc in + PLet n ty' val' sc' + ai env (PPi p n ty sc) = let ty' = ai env ty + sc' = ai (n:env) sc in + PPi p n ty' sc' + ai env (PHidden tm) = PHidden (ai env tm) + ai env (PProof ts) = PProof (map (fmap (ai env)) ts) + ai env (PTactics ts) = PTactics (map (fmap (ai env)) ts) + ai env tm = tm + +aiFn :: IState -> FC -> Name -> [PArg] -> PTerm +aiFn ist fc f as + | f `elem` primNames = PApp fc (PRef fc f) as +aiFn ist fc f as + -- This is where namespaces get resolved by adding PAlternative + = case lookupCtxtName Nothing f (idris_implicits ist) of + [(f',ns)] -> mkPApp fc (length ns) (PRef fc f') (insertImpl ns as) + [] -> if f `elem` idris_metavars ist + then PApp fc (PRef fc f) as + else mkPApp fc (length as) (PRef fc f) as + alts -> PAlternative $ + map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f') + (insertImpl ns as)) alts + where + insertImpl :: [PArg] -> [PArg] -> [PArg] + insertImpl (PExp p l ty : ps) (PExp _ _ tm : given) = + PExp p l tm : insertImpl ps given + insertImpl (PConstraint p l ty : ps) (PConstraint _ _ tm : given) = + PConstraint p l tm : insertImpl ps given + insertImpl (PConstraint p l ty : ps) given = + PConstraint p l (PResolveTC fc) : insertImpl ps given + insertImpl (PImp p l n ty : ps) given = + case find n given [] of + Just (tm, given') -> PImp p l n tm : insertImpl ps given' + Nothing -> PImp p l n Placeholder : insertImpl ps given + insertImpl expected [] = [] + insertImpl _ given = given + + find n [] acc = Nothing + find n (PImp _ _ n' t : gs) acc + | n == n' = Just (t, reverse acc ++ gs) + find n (g : gs) acc = find n gs (g : acc) + +mkPApp fc a f [] = f +mkPApp fc a f as = let rest = drop a as in + appRest fc (PApp fc f (take a as)) rest + where + appRest fc f [] = f + appRest fc f (a : as) = appRest fc (PApp fc f [a]) as + +-- Find 'static' argument positions +-- (the declared ones, plus any names in argument position in the declared +-- statics) +-- FIXME: It's possible that this really has to happen after elaboration + +findStatics :: IState -> PTerm -> (PTerm, [Bool]) +findStatics ist tm = let (ns, ss) = fs tm in + runState (pos ns ss tm) [] + where fs (PPi p n t sc) + | Static <- pstatic p + = let (ns, ss) = fs sc in + (namesIn [] ist t : ns, namesIn [] ist t ++ n : ss) + | otherwise = let (ns, ss) = fs sc in + (namesIn [] ist t : ns, ss) + fs _ = ([], []) + + inOne n ns = length (filter id (map (elem n) ns)) == 1 + + pos ns ss (PPi p n t sc) + | n `inOne` ns && elem n ss + = do sc' <- pos ns ss sc + spos <- get + put (True : spos) + return (PPi (p { pstatic = Static }) n t sc') + | otherwise = do sc' <- pos ns ss sc + spos <- get + put (False : spos) + return (PPi p n t sc') + pos ns ss t = return t + +-- Debugging/logging stuff + +dumpDecls :: [PDecl] -> String +dumpDecls [] = "" +dumpDecls (d:ds) = dumpDecl d ++ "\n" ++ dumpDecls ds + +dumpDecl (PFix _ f ops) = show f ++ " " ++ showSep ", " ops +dumpDecl (PTy _ _ n t) = "tydecl " ++ show n ++ " : " ++ showImp True t +dumpDecl (PClauses _ _ n cs) = "pat " ++ show n ++ "\t" ++ showSep "\n\t" (map (showCImp True) cs) +dumpDecl (PData _ _ d) = showDImp True d +dumpDecl (PParams _ ns ps) = "params {" ++ show ns ++ "\n" ++ dumpDecls ps ++ "}\n" +dumpDecl (PNamespace n ps) = "namespace {" ++ n ++ "\n" ++ dumpDecls ps ++ "}\n" +dumpDecl (PSyntax _ syn) = "syntax " ++ show syn +dumpDecl (PClass _ _ cs n ps ds) + = "class " ++ show cs ++ " " ++ show n ++ " " ++ show ps ++ "\n" ++ dumpDecls ds +dumpDecl (PInstance _ _ cs n _ t ds) + = "instance " ++ show cs ++ " " ++ show n ++ " " ++ show t ++ "\n" ++ dumpDecls ds +dumpDecl _ = "..." +-- dumpDecl (PImport i) = "import " ++ i + +-- for 6.12/7 compatibility +data EitherErr a b = LeftErr a | RightOK b + +instance Monad (EitherErr a) where + return = RightOK + + (LeftErr e) >>= k = LeftErr e + RightOK v >>= k = k v + +toEither (LeftErr e) = Left e +toEither (RightOK ho) = Right ho + +-- syntactic match of a against b, returning pair of variables in a +-- and what they match. Returns the pair that failed if not a match. + +matchClause :: PTerm -> PTerm -> Either (PTerm, PTerm) [(Name, PTerm)] +matchClause = matchClause' False + +matchClause' :: Bool -> PTerm -> PTerm -> Either (PTerm, PTerm) [(Name, PTerm)] +matchClause' names x y = checkRpts $ match (fullApp x) (fullApp y) where + matchArg x y = match (fullApp (getTm x)) (fullApp (getTm y)) + + fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs)) + fullApp x = x + + match' x y = match (fullApp x) (fullApp y) + match (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x]) x' + | PConstant (I _) <- getTm x = match (getTm x) x' + match x' (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x]) + | PConstant (I _) <- getTm x = match (getTm x) x' + match (PApp _ f args) (PApp _ f' args') + | length args == length args' + = do mf <- match' f f' + ms <- zipWithM matchArg args args' + return (mf ++ concat ms) +-- match (PRef _ n) (PRef _ n') | n == n' = return [] +-- | otherwise = Nothing + match (PRef f n) (PApp _ x []) = match (PRef f n) x + match (PApp _ x []) (PRef f n) = match x (PRef f n) + match (PRef _ n) (PRef _ n') | n == n' = return [] + match (PRef _ n) tm | not names = return [(n, tm)] + match (PEq _ l r) (PEq _ l' r') = do ml <- match' l l' + mr <- match' r r' + return (ml ++ mr) + match (PPair _ l r) (PPair _ l' r') = do ml <- match' l l' + mr <- match' r r' + return (ml ++ mr) + match (PDPair _ l t r) (PDPair _ l' t' r') = do ml <- match' l l' + mt <- match' t t' + mr <- match' r r' + return (ml ++ mt ++ mr) + match (PAlternative as) (PAlternative as') + = do ms <- zipWithM match' as as' + return (concat ms) + match a@(PAlternative as) b + = do let ms = zipWith match' as (repeat b) + case (rights (map toEither ms)) of + (x: _) -> return x + _ -> LeftErr (a, b) + match (PCase _ _ _) _ = return [] -- lifted out + match (PMetavar _) _ = return [] -- modified + match (PQuote _) _ = return [] + match (PProof _) _ = return [] + match (PTactics _) _ = return [] + match (PRefl _) (PRefl _) = return [] + match (PResolveTC _) (PResolveTC _) = return [] + match (PTrue _) (PTrue _) = return [] + match (PFalse _) (PFalse _) = return [] + match (PReturn _) (PReturn _) = return [] + match (PPi _ _ t s) (PPi _ _ t' s') = do mt <- match' t t' + ms <- match' s s' + return (mt ++ ms) + match (PLam _ t s) (PLam _ t' s') = do mt <- match' t t' + ms <- match' s s' + return (mt ++ ms) + match (PLet _ t ty s) (PLet _ t' ty' s') = do mt <- match' t t' + mty <- match' ty ty' + ms <- match' s s' + return (mt ++ mty ++ ms) + match (PHidden x) (PHidden y) = match' x y + match Placeholder _ = return [] + match _ Placeholder = return [] + match (PResolveTC _) _ = return [] + match a b | a == b = return [] + | otherwise = LeftErr (a, b) + + checkRpts (RightOK ms) = check ms where + check ((n,t):xs) + | Just t' <- lookup n xs = if t/=t' && t/=Placeholder && t'/=Placeholder + then Left (t, t') + else check xs + check (_:xs) = check xs + check [] = Right ms + checkRpts (LeftErr x) = Left x + +substMatches :: [(Name, PTerm)] -> PTerm -> PTerm +substMatches [] t = t +substMatches ((n,tm):ns) t = substMatch n tm (substMatches ns t) + +substMatch :: Name -> PTerm -> PTerm -> PTerm +substMatch n tm t = sm t where + sm (PRef _ n') | n == n' = tm + sm (PLam x t sc) = PLam x (sm t) (sm sc) + sm (PPi p x t sc) = PPi p x (sm t) (sm sc) + sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as) + sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as) + sm (PEq f x y) = PEq f (sm x) (sm y) + sm (PPair f x y) = PPair f (sm x) (sm y) + sm (PDPair f x t y) = PDPair f (sm x) (sm t) (sm y) + sm (PAlternative as) = PAlternative (map sm as) + sm (PHidden x) = PHidden (sm x) + sm x = x + +shadow :: Name -> Name -> PTerm -> PTerm +shadow n n' t = sm t where + sm (PRef fc x) | n == x = PRef fc n' + sm (PLam x t sc) = PLam x (sm t) (sm sc) + sm (PPi p x t sc) = PPi p x (sm t) (sm sc) + sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as) + sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as) + sm (PEq f x y) = PEq f (sm x) (sm y) + sm (PPair f x y) = PPair f (sm x) (sm y) + sm (PDPair f x t y) = PDPair f (sm x) (sm t) (sm y) + sm (PAlternative as) = PAlternative (map sm as) + sm (PHidden x) = PHidden (sm x) + sm x = x + diff --git a/src/Idris/Compiler.hs b/src/Idris/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Compiler.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE PatternGuards #-} + +module Idris.Compiler where + +import Idris.AbsSyntax +import Idris.Transforms + +import Core.TT +import Core.Evaluate +import Core.CaseTree + +import Control.Monad.State +import Data.List +import System.Process +import System.IO +import System.Directory +import System.Environment + +import Epic.Epic hiding (Term, Type, Name, fn, compile) +import qualified Epic.Epic as E + +primDefs = [UN "mkForeign", UN "FalseElim"] + +compile :: FilePath -> Term -> Idris () +compile f tm + = do checkMVs + ds <- mkDecls tm + objs <- getObjectFiles + libs <- getLibs + hdrs <- getHdrs + let incs = map Include hdrs + so <- getSO + case so of + Nothing -> + do m <- epicMain tm + let mainval = EpicFn (name "main") m + liftIO $ compileObjWith [Debug] + (mkProgram (incs ++ mainval : ds)) (f ++ ".o") + liftIO $ link ((f ++ ".o") : objs ++ (map ("-l"++) libs)) f + where checkMVs = do i <- get + case idris_metavars i \\ primDefs of + [] -> return () + ms -> fail $ "There are undefined metavariables: " ++ show ms + +mkDecls :: Term -> Idris [EpicDecl] +mkDecls t = do i <- getIState + decls <- mapM build (ctxtAlist (tt_ctxt i)) + return $ basic_defs ++ decls + +-- EpicFn (name "main") epicMain : decls + +ename x = name ("idris_" ++ show x) +aname x = name ("a_" ++ show x) + +epicMain tm = do e <- epic tm + return $ effect_ e + +-- epicMain = effect_ $ -- ref (ename (UN "run__IO")) @@ +-- ref (ename (NS (UN "main") ["main"])) + +class ToEpic a where + epic :: a -> Idris E.Term + +build :: (Name, Def) -> Idris EpicDecl +build (n, d) = do i <- getIState + case lookup n (idris_prims i) of + Just opDef -> return $ EpicFn (ename n) opDef + _ -> do def <- epic d + logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def + return $ EpicFn (ename n) def + +impossible = int 42424242 + +instance ToEpic Def where + epic (Function tm _) = epic tm + epic (CaseOp _ _ pats _ _ args sc) = epic (args, sc) -- optimised version + epic _ = return impossible + +instance ToEpic (TT Name) where + epic tm = epic' [] tm where + epic' env tm@(App f a) + | (P _ (UN "mkForeign") _, args) <- unApply tm + = doForeign args + | (P _ (UN "lazy") _, [_,arg]) <- unApply tm + = do arg' <- epic' env arg + return $ lazy_ arg' + | (P _ (UN "prim__IO") _, [v]) <- unApply tm + = epic' env v + | (P _ (UN "io_bind") _, [_,_,v,k]) <- unApply tm + = do v' <- epic' env v + k' <- epic' env k + return (k' @@ (effect_ v')) + | (P (DCon t a) n _, args) <- unApply tm + = epicCon env t a n args + epic' env (P (DCon t a) n _) = return $ con_ t + epic' env (P (TCon t a) n _) = return $ con_ t + epic' env (P _ n _) = return $ ref (ename n) + epic' env (V i) = return $ ref (env!!i) + epic' env (Bind n (Lam _) sc) + = do sc' <- epic' (aname n : env) sc + return $ term ([aname n], sc') + epic' env (Bind n (Let _ v) sc) + = do sc' <- epic' (aname n : env) sc + v' <- epic' env v + return $ let_ v' (aname n, sc') + epic' env (Bind _ _ _) = return impossible + epic' env (App f a) = do f' <- epic' env f + a' <- epic' env a + return (f' @@ a') + epic' env (Constant c) = epic c + epic' env Erased = return impossible + epic' env (Set _) = return impossible + + epicCon env t arity n args + | length args == arity = buildApp env (con_ t) args + | otherwise = let extra = satArgs (arity - length args) in + do sc' <- epicCon env t arity n + (args ++ map (\n -> P Bound n undefined) extra) + return $ term (map ename extra, sc') + + satArgs n = map (\i -> MN i "sat") [1..n] + + buildApp env e [] = return e + buildApp env e (x:xs) = do x' <- epic' env x + buildApp env (e @@ x') xs + + +doForeign :: [TT Name] -> Idris E.Term +doForeign (_ : fgn : args) + | (_, (Constant (Str fgnName) : fgnArgTys : P _ (UN ret) _ : [])) <- unApply fgn + = let tys = getFTypes fgnArgTys + rty = mkEty ret in + do args' <- mapM epic args + -- wrap it in a prim__IO + -- return $ con_ 0 @@ impossible @@ + return $ lazy_ $ foreign_ rty fgnName (zip args' tys) + | otherwise = fail "Badly formed foreign function call" + +getFTypes :: TT Name -> [E.Type] +getFTypes tm = case unApply tm of + (nil, []) -> [] + (cons, [(P _ (UN ty) _), xs]) -> + let rest = getFTypes xs in + mkEty ty : rest + +mkEty "FInt" = tyInt +mkEty "FFloat" = tyFloat +mkEty "FChar" = tyChar +mkEty "FString" = tyString +mkEty "FPtr" = tyPtr +mkEty "FUnit" = tyUnit + +instance ToEpic Const where + epic (I i) = return (int i) + epic (BI i) = return (bigint i) + epic (Fl f) = return (float f) + epic (Str s) = return (str s) + epic (Ch c) = return (char c) + epic IType = return $ con_ 1 + epic FlType = return $ con_ 2 + epic ChType = return $ con_ 3 + epic StrType = return $ con_ 4 + epic PtrType = return $ con_ 5 + epic BIType = return $ con_ 6 + +instance ToEpic ([Name], SC) where + epic (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree + tree' <- epic tree + return $ term (map ename args, tree') + +instance ToEpic SC where + epic (Case n [ConCase _ i ns sc]) + = epicLet n ns 0 sc + where + epicLet x [] _ sc = epic sc + epicLet x (n:ns) i sc + = do sc' <- epicLet x ns (i+1) sc + return $ let_ (ref (ename x) !. i) (ename n, sc') + + epic (STerm t) = epic t + epic (UnmatchedCase str) = return $ error_ str + epic (Case n alts) = do alts' <- mapM mkEpicAlt alts + return $ case_ (ref (ename n)) alts' + where + mkEpicAlt (ConCase n t args rhs) = do rhs' <- epic rhs + return $ con t (map ename args, rhs') + mkEpicAlt (ConstCase (I i) rhs) = do rhs' <- epic rhs + return $ constcase i rhs' + mkEpicAlt (ConstCase IType rhs) = do rhs' <- epic rhs + return $ defaultcase rhs' + mkEpicAlt (ConstCase c rhs) + = fail $ "Can only pattern match on integer constants (" ++ show c ++ ")" + mkEpicAlt (DefaultCase rhs) = do rhs' <- epic rhs + return $ defaultcase rhs' + +tempfile :: IO (FilePath, Handle) +tempfile = do env <- environment "TMPDIR" + let dir = case env of + Nothing -> "/tmp" + (Just d) -> d + openTempFile dir "esc" + +environment :: String -> IO (Maybe String) +environment x = catch (do e <- getEnv x + return (Just e)) + (\_ -> return Nothing) + diff --git a/src/Idris/Coverage.hs b/src/Idris/Coverage.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Coverage.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE PatternGuards #-} + +module Idris.Coverage where + +import Core.TT +import Core.Evaluate +import Idris.AbsSyntax +import Idris.Delaborate + +import Data.List +import Debug.Trace + +-- Given a list of LHSs, generate a extra clauses which cover the remaining +-- cases. The ones which haven't been provided are marked 'absurd' so that the +-- checker will make sure they can't happen. + +-- This will only work after the given clauses have been typechecked and the +-- names are fully explicit! + +genClauses :: FC -> Name -> [Term] -> [PClause] -> Idris [PClause] +genClauses fc n xs given + = do i <- getIState + let lhss = map (getLHS i) xs + let argss = transpose lhss + let all_args = map (genAll i) argss + logLvl 7 $ "COVERAGE of " ++ show n + logLvl 10 $ show argss ++ "\n" ++ show all_args + logLvl 10 $ "Original: \n" ++ + showSep "\n" (map (\t -> showImp True (delab' i t True)) xs) + let parg = case lookupCtxt Nothing n (idris_implicits i) of + (p : _) -> p + _ -> repeat (pexp Placeholder) + let new = mnub i $ filter (noMatch i) $ mkClauses parg all_args + logLvl 7 $ "New clauses: \n" ++ showSep "\n" (map (showImp True) new) + return (map (\t -> PClause n t [] PImpossible []) new) + where getLHS i term + | (f, args) <- unApply term = map (\t -> delab' i t True) args + | otherwise = [] + + lhsApp (PClause _ l _ _ _) = l + lhsApp (PWith _ l _ _ _) = l + + mnub i [] = [] + mnub i (x : xs) = + if (any (\t -> case matchClause x t of + Right _ -> True + Left _ -> False) xs) then mnub i xs + else x : mnub i xs + + noMatch i tm = all (\x -> case matchClause (delab' i x True) tm of + Right _ -> False + Left miss -> True) xs + + + mkClauses :: [PArg] -> [[PTerm]] -> [PTerm] + mkClauses parg args + = do args' <- mkArg args + let tm = PApp fc (PRef fc n) (zipWith upd args' parg) + return tm + where + mkArg :: [[PTerm]] -> [[PTerm]] + mkArg [] = return [] + mkArg (a : as) = do a' <- a + as' <- mkArg as + return (a':as') + +genAll :: IState -> [PTerm] -> [PTerm] +genAll i args = concatMap otherPats (nub args) + where + otherPats :: PTerm -> [PTerm] + otherPats o@(PRef fc n) = ops fc n [] o + otherPats o@(PApp _ (PRef fc n) xs) = ops fc n xs o + otherPats arg = return arg + + ops fc n xs o + | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef Nothing n (tt_ctxt i) + = do xs' <- mapM otherPats (map getTm xs) + let p = PApp fc (PRef fc n) (zipWith upd xs' xs) + let tyn = getTy n (tt_ctxt i) + case lookupCtxt Nothing tyn (idris_datatypes i) of + (TI ns : _) -> p : map (mkPat fc) (ns \\ [n]) + _ -> [p] + ops fc n arg o = return o + + getTy n ctxt = case lookupTy Nothing n ctxt of + (t : _) -> case unApply (getRetTy t) of + (P _ tyn _, _) -> tyn + x -> error $ "Can't happen getTy 1 " ++ show (n, x) + _ -> error "Can't happen getTy 2" + + mkPat fc x = case lookupCtxt Nothing x (idris_implicits i) of + (pargs : _) + -> PApp fc (PRef fc x) (map (upd Placeholder) pargs) + _ -> error "Can't happen - genAll" + +upd p' p = p { getTm = p' } + diff --git a/src/Idris/DataOpts.hs b/src/Idris/DataOpts.hs new file mode 100644 --- /dev/null +++ b/src/Idris/DataOpts.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE PatternGuards #-} + +module Idris.DataOpts where + +-- Forcing, detagging and collapsing + +import Idris.AbsSyntax +import Core.TT + +import Data.List +import Data.Maybe +import Debug.Trace + +-- Calculate the forceable arguments to a constructor and update the set of +-- optimisations + +forceArgs :: Name -> Type -> Idris () +forceArgs n t = do let fargs = force 0 t + i <- getIState + copt <- case lookupCtxt Nothing n (idris_optimisation i) of + [] -> return $ Optimise False [] [] + (op:_) -> return op + let opts = addDef n (copt { forceable = fargs }) (idris_optimisation i) + putIState (i { idris_optimisation = opts }) + addIBC (IBCOpt n) + iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n from " ++ + show t + where + force :: Int -> Term -> [Int] + force i (Bind _ (Pi _) sc) + = force (i + 1) $ instantiate (P Bound (MN i "?") Erased) sc + force _ sc@(App f a) + | (_, args) <- unApply sc + = nub $ concatMap guarded args + force _ _ = [] + + isF (P _ (MN force "?") _) = Just force + isF _ = Nothing + + guarded :: Term -> [Int] + guarded t@(App f a) + | (P (TCon _ _) _ _, args) <- unApply t + = mapMaybe isF args ++ concatMap guarded args + | (P (DCon _ _) _ _, args) <- unApply t + = mapMaybe isF args ++ concatMap guarded args + guarded t = mapMaybe isF [t] + +-- Calculate whether a collection of constructors is collapsible + +collapseCons :: Name -> [(Name, Type)] -> Idris () +collapseCons ty cons = + do i <- getIState + return () + +class Optimisable term where + applyOpts :: term -> Idris term + +instance (Optimisable a, Optimisable b) => Optimisable (a, b) where + applyOpts (x, y) = do x' <- applyOpts x + y' <- applyOpts y + return (x', y') + +instance Optimisable a => Optimisable [a] where + applyOpts = mapM applyOpts + +-- Raw is for compile time optimisation (before type checking) +-- Term is for run time optimisation (after type checking, collapsing allowed) + +-- Compile time: no collapsing + +instance Optimisable Raw where + applyOpts t@(RApp f a) + | (Var n, args) <- raw_unapply t -- MAGIC HERE + = do args' <- mapM applyOpts args + i <- getIState + case lookupCtxt Nothing n (idris_optimisation i) of + (oi:_) -> return $ applyDataOpt oi n args' + _ -> return (raw_apply (Var n) args') + | otherwise = do f' <- applyOpts f + a' <- applyOpts a + return (RApp f' a') + applyOpts (RBind n b t) = do b' <- applyOpts b + t' <- applyOpts t + return (RBind n b' t') + applyOpts (RForce t) = applyOpts t + applyOpts t = return t + +instance Optimisable t => Optimisable (Binder t) where + applyOpts (Let t v) = do t' <- applyOpts t + v' <- applyOpts v + return (Let t' v') + applyOpts b = do t' <- applyOpts (binderTy b) + return (b { binderTy = t' }) + + +applyDataOpt :: OptInfo -> Name -> [Raw] -> Raw +applyDataOpt oi n args + = let args' = zipWith doForce (map (\x -> x `elem` (forceable oi)) [0..]) + args in + raw_apply (Var n) args' + where + doForce True a = RForce a + doForce False a = a + +-- Run-time: do everything + +instance Optimisable (TT Name) where + applyOpts t@(App f a) + | (c@(P (DCon t arity) n _), args) <- unApply t -- MAGIC HERE + = do args' <- mapM applyOpts args + i <- getIState + case lookupCtxt Nothing n (idris_optimisation i) of + (oi:_) -> do return $ applyDataOptRT oi n t arity args' + _ -> return (mkApp c args') + | otherwise = do f' <- applyOpts f + a' <- applyOpts a + return (App f' a') + applyOpts (Bind n b t) = do b' <- applyOpts b + t' <- applyOpts t + return (Bind n b' t') + applyOpts t = return t + +-- Need to saturate arguments first to ensure that erasure happens uniformly + +applyDataOptRT :: OptInfo -> Name -> Int -> Int -> [Term] -> Term +applyDataOptRT oi n tag arity args + | length args == arity = doOpts n args (collapsible oi) (forceable oi) + | otherwise = let extra = satArgs (arity - length args) + tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra) + (collapsible oi) (forceable oi) in + bind extra tm + where + satArgs n = map (\i -> MN i "sat") [1..n] + + bind [] tm = tm + bind (n:ns) tm = Bind n (Lam Erased) (pToV n (bind ns tm)) + + doOpts n args True f = Erased + doOpts n args _ forced + = let args' = filter keep (zip (map (\x -> x `elem` forced) [0..]) + args) in + mkApp (P (DCon tag (arity - length forced)) n Erased) (map snd args') + + keep (forced, _) = not forced + diff --git a/src/Idris/Delaborate.hs b/src/Idris/Delaborate.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Delaborate.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE PatternGuards #-} + +module Idris.Delaborate where + +-- Convert core TT back into high level syntax, primarily for display +-- purposes. + +import Idris.AbsSyntax +import Core.TT + +import Debug.Trace + +delab :: IState -> Term -> PTerm +delab i tm = delab' i tm False + +delab' :: IState -> Term -> Bool -> PTerm +delab' ist tm fullname = de [] tm + where + un = FC "(val)" 0 + + de env (App f a) = deFn env f [a] + de env (V i) | i < length env = PRef un (env!!i) + | otherwise = PRef un (UN ("v" ++ show i ++ "")) + de env (P _ n _) | n == unitTy = PTrue un + | n == unitCon = PTrue un + | n == falseTy = PFalse un + | otherwise = PRef un (dens n) + de env (Bind n (Lam ty) sc) = PLam n (de env ty) (de (n:env) sc) + de env (Bind n (Pi ty) sc) = PPi expl n (de env ty) (de (n:env) sc) + de env (Bind n (Let ty val) sc) + = PLet n (de env ty) (de env val) (de (n:env) sc) + de env (Bind n _ sc) = de (n:env) sc + de env (Constant i) = PConstant i + de env Erased = Placeholder + de env (Set i) = PSet + + dens x | fullname = x + dens ns@(NS n _) = case lookupCtxt Nothing n (idris_implicits ist) of + [_] -> n -- just one thing + _ -> ns + dens n = n + + deFn env (App f a) args = deFn env f (a:args) + deFn env (P _ n _) [l,r] | n == pairTy = PPair un (de env l) (de env r) + | n == eqCon = PRefl un + | n == UN "lazy" = de env r + | n == UN "Exists" = PDPair un (de env l) Placeholder + (de env r) + deFn env (P _ n _) [_,_,l,r] | n == pairCon = PPair un (de env l) (de env r) + | n == eqTy = PEq un (de env l) (de env r) + | n == UN "Ex_intro" = PDPair un (de env l) Placeholder + (de env r) + deFn env (P _ n _) args = mkPApp (dens n) (map (de env) args) + deFn env f args = PApp un (de env f) (map pexp (map (de env) args)) + + mkPApp n args + | [imps] <- lookupCtxt Nothing n (idris_implicits ist) + = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args) + | otherwise = PApp un (PRef un n) (map pexp args) + + imp (PImp p l n _) arg = PImp p l n arg + imp (PExp p l _) arg = PExp p l arg + imp (PConstraint p l _) arg = PConstraint p l arg + +pshow :: IState -> Err -> String +pshow i (Msg s) = s +pshow i (CantUnify x y e s) = "Can't unify " ++ show (delab i x) + ++ " with " ++ show (delab i y) +-- ++ "\n\t(" ++ pshow i e ++ ")" +pshow i (NotInjective p x y) = "Can't verify injectivity of " ++ show (delab i p) ++ + " when unifying " ++ show (delab i x) ++ " and " ++ + show (delab i y) +pshow i (IncompleteTerm t) = "Incomplete term " ++ show t +pshow i UniverseError = "Universe inconsistency" +pshow i ProgramLineComment = "Program line next to comment" +pshow i (At f e) = show f ++ ":" ++ pshow i e + diff --git a/src/Idris/ElabDecls.hs b/src/Idris/ElabDecls.hs new file mode 100644 --- /dev/null +++ b/src/Idris/ElabDecls.hs @@ -0,0 +1,634 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor #-} + +module Idris.ElabDecls where + +import Idris.AbsSyntax +import Idris.Error +import Idris.Delaborate +import Idris.Imports +import Idris.ElabTerm +import Idris.Coverage +import Idris.DataOpts +import Paths_idris + +import Core.TT +import Core.Elaborate hiding (Tactic(..)) +import Core.Evaluate +import Core.Typecheck +import Core.CaseTree + +import Control.Monad +import Control.Monad.State +import Data.List +import Data.Maybe +import Debug.Trace + + +recheckC ctxt fc env t + = do -- t' <- applyOpts (forget t) (doesn't work, or speed things up...) + (tm, ty, cs) <- tclift $ recheck ctxt env (forget t) t + addConstraints fc cs + return (tm, ty) + +checkDef fc ns = do ctxt <- getContext + mapM (\(n, t) -> do (t', _) <- recheckC ctxt fc [] t + return (n, t')) ns + +elabType :: ElabInfo -> SyntaxInfo -> FC -> Name -> PTerm -> Idris () +elabType info syn fc n ty' = {- let ty' = piBind (params info) ty_in + n = liftname info n_in in -} + do checkUndefined fc n + ctxt <- getContext + i <- get + ty' <- implicit syn n ty' + let ty = addImpl i ty' + logLvl 2 $ show n ++ " type " ++ showImp True ty + ((ty', defer, is), log) <- tclift $ elaborate ctxt n (Set (UVal 0)) [] + (erun fc (build i info False n ty)) + (cty, _) <- recheckC ctxt fc [] ty' + logLvl 2 $ "---> " ++ show cty + let nty = normalise ctxt [] cty + ds <- checkDef fc ((n, nty):defer) + addIBC (IBCDef n) + addDeferred ds + mapM_ (elabCaseBlock info) is + +elabData :: ElabInfo -> SyntaxInfo -> FC -> PData -> Idris () +elabData info syn fc (PDatadecl n t_in dcons) + = do iLOG (show fc) + checkUndefined fc n + ctxt <- getContext + i <- get + t_in <- implicit syn n t_in + let t = addImpl i t_in + ((t', defer, is), log) <- tclift $ elaborate ctxt n (Set (UVal 0)) [] + (erun fc (build i info False n t)) + def' <- checkDef fc defer + addDeferred def' + mapM_ (elabCaseBlock info) is + (cty, _) <- recheckC ctxt fc [] t' + logLvl 2 $ "---> " ++ show cty + updateContext (addTyDecl n cty) -- temporary, to check cons + cons <- mapM (elabCon info syn) dcons + ttag <- getName + i <- get + put (i { idris_datatypes = addDef n (TI (map fst cons)) + (idris_datatypes i) }) + addIBC (IBCDef n) + addIBC (IBCData n) + collapseCons n cons + updateContext (addDatatype (Data n ttag cty cons)) + +elabCon :: ElabInfo -> SyntaxInfo -> (Name, PTerm, FC) -> Idris (Name, Type) +elabCon info syn (n, t_in, fc) + = do checkUndefined fc n + ctxt <- getContext + i <- get + t_in <- implicit syn n t_in + let t = addImpl i t_in + logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ showImp True t + ((t', defer, is), log) <- tclift $ elaborate ctxt n (Set (UVal 0)) [] + (erun fc (build i info False n t)) + logLvl 2 $ "Rechecking " ++ show t' + def' <- checkDef fc defer + addDeferred def' + mapM_ (elabCaseBlock info) is + ctxt <- getContext + (cty, _) <- recheckC ctxt fc [] t' + logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty + addIBC (IBCDef n) + forceArgs n cty + return (n, cty) + +elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris () +elabClauses info fc opts n_in cs = let n = liftname info n_in in + do pats_in <- mapM (elabClause info fc (TCGen `elem` opts)) cs + solveDeferred n + let pats = mapMaybe id pats_in + logLvl 3 (showSep "\n" (map (\ (l,r) -> + show l ++ " = " ++ + show r) pats)) + ist <- get + let tcase = opt_typecase (idris_options ist) + let pdef = map debind (map (simpl (tt_ctxt ist)) pats) + cov <- coverage + pcover <- + if cov + then idrisCatch + (do missing <- genClauses fc n (map fst pdef) cs + mapM_ (elabClause info fc True) missing + return True) + (\c -> do -- iputStrLn $ "Warning: " ++ show c + return False) + else return False + pdef' <- applyOpts pdef + let tree = simpleCase tcase pcover pdef + let tree' = simpleCase tcase pcover pdef' + tclift $ sameLength pdef + logLvl 3 (show tree) + logLvl 3 $ "Optimised: " ++ show tree' + ctxt <- getContext + ist <- get + put (ist { idris_patdefs = addDef n pdef' (idris_patdefs ist) }) + case lookupTy (namespace info) n ctxt of + [ty] -> do updateContext (addCasedef n (inlinable opts) + tcase pcover pdef pdef' ty) + addIBC (IBCDef n) + [] -> return () + where + debind (x, y) = (depat x, depat y) + depat (Bind n (PVar t) sc) = depat (instantiate (P Bound n t) sc) + depat x = x + + simpl ctxt (x, y) = (x, simplify ctxt [] y) + + sameLength ((x, _) : xs) + = do l <- sameLength xs + let (f, as) = unApply x + if (null xs || l == length as) then return (length as) + else tfail (At fc (Msg "Clauses have differing numbers of arguments ")) + sameLength [] = return 0 + +elabVal :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type) +elabVal info aspat tm_in + = do ctxt <- getContext + i <- get + let tm = addImpl i tm_in + logLvl 10 (showImp True tm) + ((tm', defer, is), _) <- tclift $ elaborate ctxt (MN 0 "val") infP [] + (build i info aspat (MN 0 "val") (infTerm tm)) + logLvl 3 ("Value: " ++ show tm') + let vtm = getInferTerm tm' + logLvl 2 (show vtm) + recheckC ctxt (FC "prompt" 0) [] vtm + +elabClause :: ElabInfo -> FC -> Bool -> PClause -> Idris (Maybe (Term, Term)) +elabClause info fc tcgen (PClause fname lhs_in [] PImpossible []) + = do ctxt <- getContext + i <- get + let lhs = addImpl i lhs_in + -- if the LHS type checks, it is possible, so report an error + case elaborate ctxt (MN 0 "patLHS") infP [] + (erun fc (buildTC i info True tcgen fname (infTerm lhs))) of + OK ((lhs', _, _), _) -> + do let lhs_tm = orderPats (getInferTerm lhs') + checkInferred fc (delab' i lhs_tm True) lhs + fail $ show fc ++ ":" ++ showImp True (delab' i lhs_tm True) ++ " is a possible case" + ++ "\n" ++ showImp True lhs + Error _ -> return () + return Nothing +elabClause info fc tcgen (PClause fname lhs_in withs rhs_in whereblock) + = do ctxt <- getContext + -- Build the LHS as an "Infer", and pull out its type and + -- pattern bindings + i <- get + let lhs = addImpl i lhs_in + logLvl 5 ("LHS: " ++ showImp True lhs) + ((lhs', dlhs, []), _) <- + tclift $ elaborate ctxt (MN 0 "patLHS") infP [] + (erun fc (buildTC i info True tcgen fname (infTerm lhs))) + let lhs_tm = orderPats (getInferTerm lhs') + let lhs_ty = getInferType lhs' + logLvl 3 (show lhs_tm) + (clhs, clhsty) <- recheckC ctxt fc [] lhs_tm + logLvl 5 ("Checked " ++ show clhs) + -- Elaborate where block + ist <- getIState + windex <- getName + let winfo = pinfo (pvars ist lhs_tm) whereblock windex + let decls = concatMap declared whereblock + let newargs = pvars ist lhs_tm + let wb = map (expandParamsD ist decorate newargs decls) whereblock + logLvl 5 $ show wb + mapM_ (elabDecl' info) wb + -- Now build the RHS, using the type of the LHS as the goal. + i <- get -- new implicits from where block + logLvl 5 (showImp True (expandParams decorate newargs decls rhs_in)) + let rhs = addImpl i (expandParams decorate newargs decls rhs_in) + -- TODO: but don't do names in scope + logLvl 2 (showImp True rhs) + ctxt <- getContext -- new context with where block added + ((rhs', defer, is), _) <- + tclift $ elaborate ctxt (MN 0 "patRHS") clhsty [] + (do pbinds lhs_tm + (_, _, is) <- erun fc (build i info False fname rhs) + psolve lhs_tm + tt <- get_term + let (tm, ds) = runState (collectDeferred tt) [] + return (tm, ds, is)) + logLvl 2 $ "---> " ++ show rhs' + when (not (null defer)) $ iLOG $ "DEFERRED " ++ show defer + def' <- checkDef fc defer + addDeferred def' + mapM_ (elabCaseBlock info) is + ctxt <- getContext + logLvl 5 $ "Rechecking" + (crhs, crhsty) <- recheckC ctxt fc [] rhs' + i <- get + checkInferred fc (delab' i crhs True) rhs + return $ Just (clhs, crhs) + where + decorate x = UN (show fname ++ "#" ++ show x) + pinfo ns ps i + = let ds = concatMap declared ps + newps = params info ++ ns + dsParams = map (\n -> (n, map fst newps)) ds + newb = addAlist dsParams (inblock info) + l = liftname info in + info { params = newps, + inblock = newb, + liftname = id -- (\n -> case lookupCtxt n newb of + -- Nothing -> n + -- _ -> MN i (show n)) . l + } + +elabClause info fc tcgen (PWith fname lhs_in withs wval_in withblock) + = do ctxt <- getContext + -- Build the LHS as an "Infer", and pull out its type and + -- pattern bindings + i <- get + let lhs = addImpl i lhs_in + logLvl 5 ("LHS: " ++ showImp True lhs) + ((lhs', dlhs, []), _) <- tclift $ elaborate ctxt (MN 0 "patLHS") infP [] + (erun fc (buildTC i info True tcgen fname (infTerm lhs))) + let lhs_tm = orderPats (getInferTerm lhs') + let lhs_ty = getInferType lhs' + let ret_ty = getRetTy lhs_ty + logLvl 3 (show lhs_tm) + (clhs, clhsty) <- recheckC ctxt fc [] lhs_tm + logLvl 5 ("Checked " ++ show clhs) + let bargs = getPBtys lhs_tm + let wval = addImpl i wval_in + logLvl 5 ("Checking " ++ showImp True wval) + -- Elaborate wval in this context + ((wval', defer, is), _) <- + tclift $ elaborate ctxt (MN 0 "withRHS") + (bindTyArgs PVTy bargs infP) [] + (do pbinds lhs_tm + -- TODO: may want where here - see winfo abpve + (_', d, is) <- erun fc (build i info False fname (infTerm wval)) + psolve lhs_tm + tt <- get_term + return (tt, d, is)) + def' <- checkDef fc defer + addDeferred def' + mapM_ (elabCaseBlock info) is + (cwval, cwvalty) <- recheckC ctxt fc [] (getInferTerm wval') + logLvl 3 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty) + windex <- getName + -- build a type declaration for the new function: + -- (ps : Xs) -> (withval : cwvalty) -> ret_ty + let wtype = bindTyArgs Pi (bargs ++ [(MN 0 "warg", getRetTy cwvalty)]) ret_ty + logLvl 3 ("New function type " ++ show wtype) + let wname = MN windex (show fname) + let imps = getImps wtype -- add to implicits context + put (i { idris_implicits = addDef wname imps (idris_implicits i) }) + addIBC (IBCDef wname) + def' <- checkDef fc [(wname, wtype)] + addDeferred def' + + -- in the subdecls, lhs becomes: + -- fname pats | wpat [rest] + -- ==> fname' ps wpat [rest], match pats against toplevel for ps + wb <- mapM (mkAuxC wname lhs (map fst bargs)) withblock + logLvl 5 ("with block " ++ show wb) + mapM_ (elabDecl info) wb + + -- rhs becomes: fname' ps wval + let rhs = PApp fc (PRef fc wname) (map (pexp . (PRef fc) . fst) bargs ++ + [pexp wval]) + logLvl 3 ("New RHS " ++ show rhs) + ctxt <- getContext -- New context with block added + i <- get + ((rhs', defer, is), _) <- + tclift $ elaborate ctxt (MN 0 "wpatRHS") clhsty [] + (do pbinds lhs_tm + (_, d, is) <- erun fc (build i info False fname rhs) + psolve lhs_tm + tt <- get_term + return (tt, d, is)) + def' <- checkDef fc defer + addDeferred def' + mapM_ (elabCaseBlock info) is + (crhs, crhsty) <- recheckC ctxt fc [] rhs' + return $ Just (clhs, crhs) + where + getImps (Bind n (Pi _) t) = pexp Placeholder : getImps t + getImps _ = [] + + mkAuxC wname lhs ns (PClauses fc o n cs) + | True = do cs' <- mapM (mkAux wname lhs ns) cs + return $ PClauses fc o wname cs' + | otherwise = fail $ show fc ++ "with clause uses wrong function name " ++ show n + mkAuxC wname lhs ns d = return $ d + + mkAux wname toplhs ns (PClause n tm_in (w:ws) rhs wheres) + = do i <- get + let tm = addImpl i tm_in + logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++ + showImp True toplhs) + case matchClause toplhs tm of + Left _ -> fail $ show fc ++ "with clause does not match top level" + Right mvars -> do logLvl 3 ("Match vars : " ++ show mvars) + lhs <- updateLHS n wname mvars ns (fullApp tm) w + return $ PClause wname lhs ws rhs wheres + mkAux wname toplhs ns (PWith n tm_in (w:ws) wval withs) + = do i <- get + let tm = addImpl i tm_in + logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++ + showImp True toplhs) + withs' <- mapM (mkAuxC wname toplhs ns) withs + case matchClause toplhs tm of + Left _ -> fail $ show fc ++ "with clause does not match top level" + Right mvars -> do lhs <- updateLHS n wname mvars ns (fullApp tm) w + return $ PWith wname lhs ws wval withs' + + updateLHS n wname mvars ns (PApp fc (PRef fc' n') args) w + = return $ substMatches mvars $ + PApp fc (PRef fc' wname) (map (pexp . (PRef fc')) ns ++ [pexp w]) + updateLHS n wname mvars ns tm w = fail $ "Not implemented match " ++ show tm + + fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs)) + fullApp x = x + +data MArgTy = IA | EA | CA deriving Show + +elabClass :: ElabInfo -> SyntaxInfo -> + FC -> [PTerm] -> + Name -> [(Name, PTerm)] -> [PDecl] -> Idris () +elabClass info syn fc constraints tn ps ds + = do let cn = UN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn) + let tty = pibind ps PSet + let constraint = PApp fc (PRef fc tn) + (map (pexp . PRef fc) (map fst ps)) + -- build data declaration + ims <- mapM tdecl (filter tydecl ds) + defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint) + (filter clause ds) + let (methods, imethods) = unzip (map (\ (x,y,z) -> (x, y)) ims) + let cty = impbind ps $ conbind constraints $ pibind methods constraint + let cons = [(cn, cty, fc)] + let ddecl = PData syn fc (PDatadecl tn tty cons) + elabDecl info ddecl + -- for each constraint, build a top level function to chase it + let usyn = syn { using = ps ++ using syn } + fns <- mapM (cfun cn constraint usyn (map fst imethods)) constraints + mapM_ (elabDecl info) (concat fns) + -- for each method, build a top level function + fns <- mapM (tfun cn constraint usyn (map fst imethods)) imethods + mapM_ (elabDecl info) (concat fns) + -- add the default definitions + mapM_ (elabDecl info) (concat (map (snd.snd) defs)) + i <- get + let defaults = map (\ (x, (y, z)) -> (x,y)) defs + put (i { idris_classes = addDef tn (CI cn imethods defaults (map fst ps)) + (idris_classes i) }) + addIBC (IBCClass tn) + where + pibind [] x = x + pibind ((n, ty): ns) x = PPi expl n ty (pibind ns x) + impbind [] x = x + impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x) + conbind (ty : ns) x = PPi constraint (MN 0 "c") ty (conbind ns x) + conbind [] x = x + + tdecl (PTy syn _ n t) = do t' <- implicit syn n t + return ( (n, (toExp (map fst ps) Exp t')), + (n, (toExp (map fst ps) Imp t')), + (n, (syn, t) ) ) + tdecl _ = fail "Not allowed in a class declaration" + + -- Create default definitions + defdecl mtys c d@(PClauses fc opts n cs) = + case lookup n mtys of + Just (syn, ty) -> do let ty' = insertConstraint c ty + let ds = map (decorateid defaultdec) + [PTy syn fc n ty', + PClauses fc (TCGen:opts) n cs] + iLOG (show ds) + return (n, (defaultdec n, ds)) + _ -> fail $ show n ++ " is not a method" + defdecl _ _ _ = fail "Can't happen (defdecl)" + + defaultdec (UN n) = UN ("default#" ++ n) + defaultdec (NS n ns) = NS (defaultdec n) ns + + tydecl (PTy _ _ _ _) = True + tydecl _ = False + clause (PClauses _ _ _ _) = True + clause _ = False + + cfun cn c syn all con + = do let cfn = UN ('@':show cn ++ "#" ++ show con) + let mnames = take (length all) $ map (\x -> MN x "meth") [0..] + let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames) + let lhs = PApp fc (PRef fc cfn) [pconst capp] + let rhs = PResolveTC (FC "HACK" 0) + let ty = PPi constraint (MN 0 "pc") c con + iLOG (showImp True ty) + iLOG (showImp True lhs ++ " = " ++ showImp True rhs) + return [PTy syn fc cfn ty, + PClauses fc [Inlinable,TCGen] cfn [PClause cfn lhs [] rhs []]] + + tfun cn c syn all (m, ty) + = do let ty' = insertConstraint c ty + let mnames = take (length all) $ map (\x -> MN x "meth") [0..] + let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames) + let margs = getMArgs ty + let anames = map (\x -> MN x "arg") [0..] + let lhs = PApp fc (PRef fc m) (pconst capp : lhsArgs margs anames) + let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames) + iLOG (showImp True ty) + iLOG (show (m, ty', capp, margs)) + iLOG (showImp True lhs ++ " = " ++ showImp True rhs) + return [PTy syn fc m ty', + PClauses fc [Inlinable,TCGen] m [PClause m lhs [] rhs []]] + + getMArgs (PPi (Imp _ _) n ty sc) = IA : getMArgs sc + getMArgs (PPi (Exp _ _) n ty sc) = EA : getMArgs sc + getMArgs (PPi (Constraint _ _) n ty sc) = CA : getMArgs sc + getMArgs _ = [] + + getMeth (m:ms) (a:as) x | x == a = PRef fc m + | otherwise = getMeth ms as x + + lhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : lhsArgs xs ns + lhsArgs (IA : xs) ns = lhsArgs xs ns + lhsArgs (CA : xs) ns = lhsArgs xs ns + lhsArgs [] _ = [] + + rhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : rhsArgs xs ns + rhsArgs (IA : xs) ns = pexp Placeholder : rhsArgs xs ns + rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns + rhsArgs [] _ = [] + + insertConstraint c (PPi p@(Imp _ _) n ty sc) + = PPi p n ty (insertConstraint c sc) + insertConstraint c sc = PPi constraint (MN 0 "c") c sc + + -- make arguments explicit and don't bind class parameters + toExp ns e (PPi (Imp l s) n ty sc) + | n `elem` ns = toExp ns e sc + | otherwise = PPi (e l s) n ty (toExp ns e sc) + toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc) + toExp ns e sc = sc + +elabInstance :: ElabInfo -> SyntaxInfo -> + FC -> [PTerm] -> Name -> + [PTerm] -> PTerm -> [PDecl] -> Idris () +elabInstance info syn fc cs n ps t ds + = do i <- get + (n, ci) <- case lookupCtxtName (namespace info) n (idris_classes i) of + [c] -> return c + _ -> fail $ show n ++ " is not a type class" + let iname = UN ('@':show n ++ "$" ++ show ps) + elabType info syn fc iname t + let ips = zip (class_params ci) ps + let ns = case n of + NS n ns' -> ns' + _ -> [] + let mtys = map (\ (n, t) -> let t' = substMatches ips t in + (decorate ns n, coninsert cs t', t')) + (class_methods ci) + logLvl 3 (show (mtys, ips)) + let ds' = insertDefaults (class_defaults ci) ns ds + iLOG ("Defaults inserted: " ++ show ds' ++ "\n" ++ show ci) + mapM_ (warnMissing ds' ns) (map fst (class_methods ci)) + let wb = map mkTyDecl mtys ++ map (decorateid (decorate ns)) ds' + let lhs = PRef fc iname + let rhs = PApp fc (PRef fc (instanceName ci)) + (map (pexp . mkMethApp) mtys) + let idecl = PClauses fc [Inlinable, TCGen] iname + [PClause iname lhs [] rhs wb] + iLOG (show idecl) + elabDecl info idecl + where + mkMethApp (n, _, ty) = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty)) + lamBind i (PPi (Constraint _ _) _ _ sc) sc' + = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc') + lamBind i (PPi _ n ty sc) sc' = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc') + lamBind i _ sc = sc + methArgs i (PPi (Imp _ _) n ty sc) + = PImp 0 False n (PRef fc (MN i "meth")) : methArgs (i+1) sc + methArgs i (PPi (Exp _ _) n ty sc) + = PExp 0 False (PRef fc (MN i "meth")) : methArgs (i+1) sc + methArgs i (PPi (Constraint _ _) n ty sc) + = PConstraint 0 False (PResolveTC fc) : methArgs (i+1) sc + methArgs i _ = [] + + papp fc f [] = f + papp fc f as = PApp fc f as + + decorate ns (UN n) = NS (UN ('!':n)) ns + decorate ns (NS (UN n) s) = NS (UN ('!':n)) ns + + mkTyDecl (n, t, _) = PTy syn fc n t + + conbind (ty : ns) x = PPi constraint (MN 0 "c") ty (conbind ns x) + conbind [] x = x + + coninsert cs (PPi p@(Imp _ _) n t sc) = PPi p n t (coninsert cs sc) + coninsert cs sc = conbind cs sc + + insertDefaults :: [(Name, Name)] -> [String] -> [PDecl] -> [PDecl] + insertDefaults [] ns ds = ds + insertDefaults ((n,dn) : defs) ns ds + = insertDefaults defs ns (insertDef n dn ns ds) + + insertDef meth def ns decls + | null $ filter (clauseFor meth ns) decls + = decls ++ [PClauses fc [Inlinable,TCGen] meth + [PClause meth (PApp fc (PRef fc meth) []) [] + (PApp fc (PRef fc def) []) []]] + | otherwise = decls + + warnMissing decls ns meth + | null $ filter (clauseFor meth ns) decls + = iWarn fc $ "method " ++ show meth ++ " not defined" + | otherwise = return () + + clauseFor m ns (PClauses _ _ m' _) = decorate ns m == decorate ns m' + clauseFor m ns _ = False + +decorateid decorate (PTy s f n t) = PTy s f (decorate n) t +decorateid decorate (PClauses f o n cs) + = PClauses f o (decorate n) (map dc cs) + where dc (PClause n t as w ds) = PClause (decorate n) (dappname t) as w ds + dc (PWith n t as w ds) = PWith (decorate n) (dappname t) as w + (map (decorateid decorate) ds) + dappname (PApp fc (PRef fc' n) as) = PApp fc (PRef fc' (decorate n)) as + dappname t = t + +pbinds (Bind n (PVar t) sc) = do attack; patbind n + pbinds sc +pbinds tm = return () + +pbty (Bind n (PVar t) sc) tm = Bind n (PVTy t) (pbty sc tm) +pbty _ tm = tm + +getPBtys (Bind n (PVar t) sc) = (n, t) : getPBtys sc +getPBtys _ = [] + +psolve (Bind n (PVar t) sc) = do solve; psolve sc +psolve tm = return () + +pvars ist (Bind n (PVar t) sc) = (n, delab ist t) : pvars ist sc +pvars ist _ = [] + +-- TODO: Also build a 'binary' version of each declaration for fast reloading + +elabDecl :: ElabInfo -> PDecl -> Idris () +elabDecl info d = idrisCatch (elabDecl' info d) + (\e -> do let msg = show e + setErrLine (getErrLine msg) + iputStrLn msg) + +elabDecl' info (PFix _ _ _) = return () -- nothing to elaborate +elabDecl' info (PSyntax _ p) = return () -- nothing to elaborate +elabDecl' info (PTy s f n ty) = do iLOG $ "Elaborating type decl " ++ show n + elabType info s f n ty +elabDecl' info (PData s f d) = do iLOG $ "Elaborating " ++ show (d_name d) + elabData info s f d +elabDecl' info d@(PClauses f o n ps) = do iLOG $ "Elaborating clause " ++ show n + elabClauses info f o n ps +elabDecl' info (PParams f ns ps) = mapM_ (elabDecl' pinfo) ps + where + pinfo = let ds = concatMap declared ps + newps = params info ++ ns + dsParams = map (\n -> (n, map fst newps)) ds + newb = addAlist dsParams (inblock info) in + info { params = newps, + inblock = newb } +elabDecl' info (PNamespace n ps) = mapM_ (elabDecl' ninfo) ps + where + ninfo = case namespace info of + Nothing -> info { namespace = Just [n] } + Just ns -> info { namespace = Just (n:ns) } +elabDecl' info (PClass s f cs n ps ds) = do iLOG $ "Elaborating class " ++ show n + elabClass info s f cs n ps ds +elabDecl' info (PInstance s f cs n ps t ds) + = do iLOG $ "Elaborating instance " ++ show n + elabInstance info s f cs n ps t ds +elabDecl' info (PDirective i) = i + +elabCaseBlock info d@(PClauses f o n ps) + = do addIBC (IBCDef n) + elabDecl' info d + +-- elabDecl' info (PImport i) = loadModule i + +-- Check that the result of type checking matches what the programmer wrote +-- (i.e. - if we inferred any arguments that the user provided, make sure +-- they are the same!) + +checkInferred :: FC -> PTerm -> PTerm -> Idris () +checkInferred fc inf user = + do logLvl 6 $ "Checked to\n" ++ showImp True inf ++ "\n" ++ + showImp True user + tclift $ case matchClause' True user inf of + Right vs -> return () + Left (x, y) -> tfail $ At fc + (Msg $ "The type-checked term and given term do not match: " + ++ show x ++ " and " ++ show y) +-- ++ "\n" ++ showImp True inf ++ "\n" ++ showImp True user) + diff --git a/src/Idris/ElabTerm.hs b/src/Idris/ElabTerm.hs new file mode 100644 --- /dev/null +++ b/src/Idris/ElabTerm.hs @@ -0,0 +1,451 @@ +module Idris.ElabTerm where + +import Idris.AbsSyntax + +import Core.Elaborate hiding (Tactic(..)) +import Core.TT +import Core.Evaluate + +import Control.Monad +import Control.Monad.State +import Data.List +import Debug.Trace + +-- Data to pass to recursively called elaborators; e.g. for where blocks, +-- paramaterised declarations, etc. + +data ElabInfo = EInfo { params :: [(Name, PTerm)], + inblock :: Ctxt [Name], -- names in the block, and their params + liftname :: Name -> Name, + namespace :: Maybe [String] } + +toplevel = EInfo [] emptyContext id Nothing + +type ElabD a = Elab' [PDecl] a + +-- Using the elaborator, convert a term in raw syntax to a fully +-- elaborated, typechecked term. +-- +-- If building a pattern match, we convert undeclared variables from +-- holes to pattern bindings. + +-- Also find deferred names in the term and their types + +build :: IState -> ElabInfo -> Bool -> Name -> PTerm -> + ElabD (Term, [(Name, Type)], [PDecl]) +build ist info pattern fn tm + = do elab ist info pattern False fn tm + is <- getAux + tt <- get_term + let (tm, ds) = runState (collectDeferred tt) [] + return (tm, ds, is) + +-- Build a term autogenerated as a typeclass method definition +-- (Separate, so we don't go overboard resolving things that we don't +-- know about yet on the LHS of a pattern def) + +buildTC :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm -> + ElabD (Term, [(Name, Type)], [PDecl]) +buildTC ist info pattern tcgen fn tm + = do elab ist info pattern tcgen fn tm + is <- getAux + tt <- get_term + let (tm, ds) = runState (collectDeferred tt) [] + return (tm, ds, is) + +-- Returns the set of declarations we need to add to complete the definition +-- (most likely case blocks to elaborate) + +elab :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm -> + ElabD () +elab ist info pattern tcgen fn tm + = do elabE False tm + when pattern -- convert remaining holes to pattern vars + mkPat + inj <- get_inj + mapM_ checkInjective inj + where + isph arg = case getTm arg of + Placeholder -> (True, priority arg) + _ -> (False, priority arg) + + toElab ina arg = case getTm arg of + Placeholder -> Nothing + v -> Just (priority arg, elabE ina v) + + toElab' ina arg = case getTm arg of + Placeholder -> Nothing + v -> Just (elabE ina v) + + mkPat = do hs <- get_holes + case hs of + (h: hs) -> do patvar h; mkPat + [] -> return () + + elabE ina t = {- do g <- goal + tm <- get_term + trace ("Elaborating " ++ show t ++ " : " ++ show g ++ "\n\tin " ++ show tm) + $ -} elab' ina t + + local f = do e <- get_env + return (f `elem` map fst e) + + elab' ina PSet = do apply RSet []; solve + elab' ina (PConstant c) = do apply (RConstant c) []; solve + elab' ina (PQuote r) = do fill r; solve + elab' ina (PTrue fc) = try (elab' ina (PRef fc unitCon)) + (elab' ina (PRef fc unitTy)) + elab' ina (PFalse fc) = elab' ina (PRef fc falseTy) + elab' ina (PResolveTC (FC "HACK" _)) -- for chasing parent classes + = resolveTC 2 fn ist + elab' ina (PResolveTC fc) = do c <- unique_hole (MN 0 "c") + instanceArg c + elab' ina (PRefl fc) = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder, + pimp (MN 0 "x") Placeholder]) + elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy) [pimp (MN 0 "a") Placeholder, + pimp (MN 0 "b") Placeholder, + pexp l, pexp r]) + elab' ina (PPair fc l r) = try (elabE True (PApp fc (PRef fc pairTy) + [pexp l,pexp r])) + (elabE True (PApp fc (PRef fc pairCon) + [pimp (MN 0 "A") Placeholder, + pimp (MN 0 "B") Placeholder, + pexp l, pexp r])) + elab' ina (PDPair fc l@(PRef _ n) t r) + = case t of + Placeholder -> try asType asValue + _ -> asType + where asType = elab' ina (PApp fc (PRef fc sigmaTy) + [pexp t, + pexp (PLam n Placeholder r)]) + asValue = elab' ina (PApp fc (PRef fc existsCon) + [pimp (MN 0 "a") t, + pimp (MN 0 "P") Placeholder, + pexp l, pexp r]) + elab' ina (PDPair fc l t r) = elab' ina (PApp fc (PRef fc existsCon) + [pimp (MN 0 "a") t, + pimp (MN 0 "P") Placeholder, + pexp l, pexp r]) + elab' ina (PAlternative as) + = let as' = pruneAlt as in + try (tryAll (zip (map (elab' ina) as') (map showHd as'))) + (tryAll (zip (map (elab' ina) as) (map showHd as))) + where showHd (PApp _ h _) = show h + showHd x = show x + elab' ina (PRef fc n) | pattern && not (inparamBlock n) + = do ctxt <- get_context + let iscon = isConName Nothing n ctxt + if (not iscon && ina) then erun fc $ patvar n + else try (do apply (Var n) []; solve) + (patvar n) + where inparamBlock n = case lookupCtxtName Nothing n (inblock info) of + [] -> False + _ -> True + elab' ina (PRef fc n) = erun fc $ do apply (Var n) []; solve + elab' ina (PLam n Placeholder sc) + = do attack; intro (Just n); elabE True sc; solve + elab' ina (PLam n ty sc) + = do tyn <- unique_hole (MN 0 "lamty") + claim tyn RSet + attack + introTy (Var tyn) (Just n) + -- end_unify + focus tyn + elabE True ty + elabE True sc + solve + elab' ina (PPi _ n Placeholder sc) + = do attack; arg n (MN 0 "ty"); elabE True sc; solve + elab' ina (PPi _ n ty sc) + = do attack; tyn <- unique_hole (MN 0 "ty") + claim tyn RSet + n' <- case n of + MN _ _ -> unique_hole n + _ -> return n + forall n' (Var tyn) + focus tyn + elabE True ty + elabE True sc + solve + elab' ina (PLet n ty val sc) + = do attack; + tyn <- unique_hole (MN 0 "letty") + claim tyn RSet + valn <- unique_hole (MN 0 "letval") + claim valn (Var tyn) + letbind n (Var tyn) (Var valn) + case ty of + Placeholder -> return () + _ -> do focus tyn + elabE True ty + focus valn + elabE True val + elabE True sc + solve + elab' ina (PApp fc (PRef _ f) args') + = do let args = {- case lookupCtxt f (inblock info) of + Just ps -> (map (pexp . (PRef fc)) ps ++ args') + _ ->-} args' + ivs <- get_instances + -- HACK: we shouldn't resolve type classes if we're defining an instance + -- function or default defition. + let isinf = f == inferCon || tcname f + try (do ns <- apply (Var f) (map isph args) + solve + let (ns', eargs) + = unzip $ + sortBy (\(_,x) (_,y) -> compare (priority x) (priority y)) + (zip ns args) + try (elabArgs (ina || not isinf) + [] False ns' (map (\x -> (lazyarg x, getTm x)) eargs)) + (elabArgs (ina || not isinf) + [] False (reverse ns') + (map (\x -> (lazyarg x, getTm x)) (reverse eargs)))) +-- (try (do apply2 (Var f) (map (toElab' (ina || not isinf)) args)) + (do apply_elab f (map (toElab (ina || not isinf)) args) + solve) + ivs' <- get_instances + when (not pattern || (ina && not tcgen)) $ + mapM_ (\n -> do focus n + resolveTC 7 fn ist) (ivs' \\ ivs) +-- ivs <- get_instances +-- when (not (null ivs)) $ +-- do t <- get_term +-- trace (show ivs ++ "\n" ++ show t) $ +-- mapM_ (\n -> do focus n +-- resolveTC ist) ivs + where tcArg (n, PConstraint _ _ Placeholder) = True + tcArg _ = False + + elab' a (PApp fc f [arg]) + = erun fc $ + do simple_app (elabE a f) (elabE True (getTm arg)) + solve + elab' ina Placeholder = do (h : hs) <- get_holes + movelast h + elab' ina (PMetavar n) = let n' = mkN n in + do attack; defer n'; solve + where mkN n@(NS _ _) = n + mkN n = case namespace info of + Just xs@(_:_) -> NS n xs + _ -> n + elab' ina (PProof ts) = do mapM_ (runTac True ist) ts + elab' ina (PTactics ts) = do mapM_ (runTac False ist) ts + elab' ina (PElabError e) = fail e + elab' ina c@(PCase fc scr opts) + = do attack + tyn <- unique_hole (MN 0 "scty") + claim tyn RSet + valn <- unique_hole (MN 0 "scval") + scvn <- unique_hole (MN 0 "scvar") + claim valn (Var tyn) + letbind scvn (Var tyn) (Var valn) + focus valn + elabE True scr + args <- get_env + cname <- unique_hole (mkCaseName fn) + elab' ina (PMetavar cname) + let newdef = PClauses fc [] cname (caseBlock fc cname (reverse args) opts) + -- fail $ "Not implemented " ++ show c ++ "\n" ++ show args + -- elaborate case + updateAux (newdef : ) + solve + where mkCaseName (NS n ns) = NS (mkCaseName n) ns + mkCaseName (UN x) = UN (x ++ "_case") + mkCaseName (MN i x) = MN i (x ++ "_case") + elab' ina x = fail $ "Something's gone wrong. Did you miss a semi-colon somewhere?" + + caseBlock :: FC -> Name -> [(Name, Binder Term)] -> [(PTerm, PTerm)] -> [PClause] + caseBlock fc n env opts + = let args = map mkarg (map fst (init env)) in + map (mkClause args) opts + where -- mkarg (MN _ _) = Placeholder + mkarg n = PRef fc n + mkClause args (l, r) + = PClause n (PApp fc (PRef fc n) + (map pexp args ++ [pexp l])) [] r [] + + elabArgs ina failed retry [] _ + | retry = let (ns, ts) = unzip (reverse failed) in + elabArgs ina [] False ns ts + | otherwise = return () + elabArgs ina failed r (n:ns) ((_, Placeholder) : args) + = elabArgs ina failed r ns args + elabArgs ina failed r (n:ns) ((lazy, t) : args) + | lazy && not pattern + = do elabArg n (PApp bi (PRef bi (UN "lazy")) + [pimp (UN "a") Placeholder, + pexp t]); + | otherwise = elabArg n t + where elabArg n t + = do hs <- get_holes + tm <- get_term + failed' <- -- trace (show (n, t, hs, tm)) $ + case n `elem` hs of + True -> + if r + then try (do focus n; elabE ina t; return failed) + (return ((n,(lazy, t)):failed)) + else do focus n; elabE ina t; return failed + False -> return failed + elabArgs ina failed r ns args + +pruneAlt :: [PTerm] -> [PTerm] +pruneAlt xs = map prune xs + where + prune (PApp fc1 (PRef fc2 f) as) + = PApp fc1 (PRef fc2 f) (fmap (fmap (choose f)) as) + prune t = t + + choose f (PAlternative as) = PAlternative (filter (headIs f) as) + choose f t = t + + headIs f (PApp _ (PRef _ f') _) = f == f' + headIs f _ = True -- keep if it's not an application + +trivial :: IState -> ElabD () +trivial ist = try (do elab ist toplevel False False (MN 0 "tac") (PRefl (FC "prf" 0)) + return ()) + (do env <- get_env + tryAll (map fst env) + return ()) + where + tryAll [] = fail "No trivial solution" + tryAll (x:xs) = try (elab ist toplevel False False + (MN 0 "tac") (PRef (FC "prf" 0) x)) + (tryAll xs) + +resolveTC :: Int -> Name -> IState -> ElabD () +resolveTC 0 fn ist = fail $ "Can't resolve type class" +resolveTC depth fn ist + = try (trivial ist) + (do t <- goal + let (tc, ttypes) = unApply t + needsDefault t tc ttypes + tm <- get_term +-- traceWhen (depth > 6) ("GOAL: " ++ show t ++ "\nTERM: " ++ show tm) $ +-- (tryAll (map elabTC (map fst (ctxtAlist (tt_ctxt ist))))) + blunderbuss t (map fst (ctxtAlist (tt_ctxt ist)))) + where + elabTC n | n /= fn && tcname n = (resolve n depth, show n) + | otherwise = (fail "Can't resolve", show n) + + needsDefault t num@(P _ (NS (UN "Num") ["builtins"]) _) [P Bound a _] + = do focus a + fill (RConstant IType) -- default Int + solve +-- needsDefault t f as +-- | all boundVar as = fail $ "Can't resolve " ++ show t + needsDefault t f a = return () + + boundVar (P Bound _ _) = True + boundVar _ = False + + blunderbuss t [] = fail $ "Can't resolve type class " ++ show t + blunderbuss t (n:ns) | n /= fn && tcname n = try (resolve n depth) + (blunderbuss t ns) + | otherwise = blunderbuss t ns + + resolve n depth + | depth == 0 = fail $ "Can't resolve type class" + | otherwise + = do t <- goal + -- if there's a hole in the goal, don't even try + let imps = case lookupCtxtName Nothing n (idris_implicits ist) of + [] -> [] + [args] -> map isImp (snd args) -- won't be overloaded! + args <- apply (Var n) imps + tm <- get_term + mapM_ (\ (_,n) -> do focus n + resolveTC (depth - 1) fn ist) + (filter (\ (x, y) -> not x) (zip (map fst imps) args)) + -- if there's any arguments left, we've failed to resolve + solve + where isImp (PImp p _ _ _) = (True, p) + isImp arg = (False, priority arg) + +collectDeferred :: Term -> State [(Name, Type)] Term +collectDeferred (Bind n (GHole t) app) = + do ds <- get + put ((n, t) : ds) + return app +collectDeferred (Bind n b t) = do b' <- cdb b + t' <- collectDeferred t + return (Bind n b' t') + where + cdb (Let t v) = liftM2 Let (collectDeferred t) (collectDeferred v) + cdb (Guess t v) = liftM2 Guess (collectDeferred t) (collectDeferred v) + cdb b = do ty' <- collectDeferred (binderTy b) + return (b { binderTy = ty' }) +collectDeferred (App f a) = liftM2 App (collectDeferred f) (collectDeferred a) +collectDeferred t = return t + +-- Running tactics directly + +runTac :: Bool -> IState -> PTactic -> ElabD () +runTac autoSolve ist tac = runT (fmap (addImpl ist) tac) where + runT (Intro []) = do g <- goal + attack; intro (bname g) + where + bname (Bind n _ _) = Just n + bname _ = Nothing + runT (Intro xs) = mapM_ (\x -> do attack; intro (Just x)) xs + runT Intros = do g <- goal + attack; intro (bname g) + try (runT Intros) + (return ()) + where + bname (Bind n _ _) = Just n + bname _ = Nothing + runT (Exact tm) = do elab ist toplevel False False (MN 0 "tac") tm + when autoSolve solveAll + runT (Refine fn []) + = do (fn', imps) <- case lookupCtxtName Nothing fn (idris_implicits ist) of + [] -> do a <- envArgs fn + return (fn, a) + -- FIXME: resolve ambiguities + [(n, args)] -> return $ (n, map isImp args) + ns <- apply (Var fn') (map (\x -> (x,0)) imps) + when autoSolve solveAll + where isImp (PImp _ _ _ _) = True + isImp _ = False + envArgs n = do e <- get_env + case lookup n e of + Just t -> return $ map (const False) + (getArgTys (binderTy t)) + _ -> return [] + runT (Refine fn imps) = do ns <- apply (Var fn) (map (\x -> (x,0)) imps) + when autoSolve solveAll + runT (Rewrite tm) -- to elaborate tm, let bind it, then rewrite by that + = do attack; -- (h:_) <- get_holes + tyn <- unique_hole (MN 0 "rty") + -- start_unify h + claim tyn RSet + valn <- unique_hole (MN 0 "rval") + claim valn (Var tyn) + letn <- unique_hole (MN 0 "rewrite_rule") + letbind letn (Var tyn) (Var valn) + focus valn + elab ist toplevel False False (MN 0 "tac") tm + rewrite (Var letn) + when autoSolve solveAll + runT (LetTac n tm) + = do attack + tyn <- unique_hole (MN 0 "letty") + claim tyn RSet + valn <- unique_hole (MN 0 "letval") + claim valn (Var tyn) + letn <- unique_hole n + letbind letn (Var tyn) (Var valn) + focus valn + elab ist toplevel False False (MN 0 "tac") tm + when autoSolve solveAll + runT Compute = compute + runT Trivial = do trivial ist; when autoSolve solveAll + runT (Focus n) = focus n + runT Solve = solve + runT (Try l r) = do try (runT l) (runT r) + runT (TSeq l r) = do runT l; runT r + runT x = fail $ "Not implemented " ++ show x + +solveAll = try (do solve; solveAll) (return ()) diff --git a/src/Idris/Error.hs b/src/Idris/Error.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Error.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Idris.Error where + +import Prelude hiding (catch) +import Idris.AbsSyntax +import Idris.Delaborate + +import Core.TT +import Core.Typecheck +import Core.Constraints + +import System.Console.Haskeline +import Control.Monad.State +import System.IO.Error(isUserError, ioeGetErrorString) +import Data.Char +import Data.Typeable + +iucheck :: Idris () +iucheck = do tit <- typeInType + when (not tit) $ + do ist <- get + idrisCatch (tclift $ ucheck (idris_constraints ist)) + (\e -> do let msg = show e + setErrLine (getErrLine msg) + iputStrLn msg) + +report :: IOError -> String +report e + | isUserError e = ioeGetErrorString e + | otherwise = show e + +idrisCatch :: Idris a -> (SomeException -> Idris a) -> Idris a +idrisCatch = catch + +data IdrisErr = IErr String + deriving Typeable + +instance Show IdrisErr where + show (IErr s) = s + +instance Exception IdrisErr + +ifail :: String -> Idris () +ifail str = throwIO (IErr str) + +tclift :: TC a -> Idris a +tclift tc = case tc of + OK v -> return v + Error err -> do i <- get + case err of + At (FC f l) e -> setErrLine l + _ -> return () + throwIO (IErr $ pshow i err) + +getErrLine str + = case span (/=':') str of + (_, ':':rest) -> case span isDigit rest of + (num, _) -> read num + _ -> 0 + diff --git a/src/Idris/IBC.hs b/src/Idris/IBC.hs new file mode 100644 --- /dev/null +++ b/src/Idris/IBC.hs @@ -0,0 +1,1046 @@ +{-# LANGUAGE TypeSynonymInstances #-} + +module Idris.IBC where + +import Core.Evaluate +import Core.TT +import Core.CaseTree +import Idris.Compiler +import Idris.AbsSyntax +import Idris.Imports +import Idris.Error + +import Data.Binary +import Data.List +import Data.ByteString.Lazy as B hiding (length, elem) +-- import Data.DeriveTH +import Control.Monad +import Control.Monad.State hiding (get, put) +import System.FilePath +import System.Directory + +import Paths_idris + +ibcVersion :: Word8 +ibcVersion = 8 + +data IBCFile = IBCFile { ver :: Word8, + sourcefile :: FilePath, + ibc_imports :: [FilePath], + ibc_implicits :: [(Name, [PArg])], + ibc_fixes :: [FixDecl], + ibc_statics :: [(Name, [Bool])], + ibc_classes :: [(Name, ClassInfo)], + ibc_datatypes :: [(Name, TypeInfo)], + ibc_optimise :: [(Name, OptInfo)], + ibc_syntax :: [Syntax], + ibc_keywords :: [String], + ibc_objs :: [FilePath], + ibc_libs :: [String], + ibc_hdrs :: [String], + ibc_access :: [(Name, Accessibility)], + ibc_defs :: [(Name, Def)] } +{-! +deriving instance Binary IBCFile +!-} + +initIBC :: IBCFile +initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] + +loadIBC :: FilePath -> Idris () +loadIBC fp = do iLOG $ "Loading ibc " ++ fp + ibcf <- liftIO $ (decodeFile fp :: IO IBCFile) + process ibcf fp + +writeIBC :: FilePath -> FilePath -> Idris () +writeIBC src f + = do iLOG $ "Writing ibc " ++ show f + i <- getIState + case idris_metavars i \\ primDefs of + (_:_) -> fail "Can't write ibc when there are unsolved metavariables" + [] -> return () + ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src }) + idrisCatch (do liftIO $ encodeFile f ibcf + iLOG "Written") + (\c -> do iLOG $ "Failed " ++ show c) + return () + +mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile +mkIBC [] f = return f +mkIBC (i:is) f = do ist <- getIState + logLvl 5 $ show i ++ " " ++ show (Data.List.length is) + f' <- ibc ist i f + mkIBC is f' + +ibc i (IBCFix d) f = return f { ibc_fixes = d : ibc_fixes f } +ibc i (IBCImp n) f = case lookupCtxt Nothing n (idris_implicits i) of + [v] -> return f { ibc_implicits = (n,v): ibc_implicits f } + _ -> fail "IBC write failed" +ibc i (IBCStatic n) f + = case lookupCtxt Nothing n (idris_statics i) of + [v] -> return f { ibc_statics = (n,v): ibc_statics f } + _ -> fail "IBC write failed" +ibc i (IBCClass n) f + = case lookupCtxt Nothing n (idris_classes i) of + [v] -> return f { ibc_classes = (n,v): ibc_classes f } + _ -> fail "IBC write failed" +ibc i (IBCData n) f + = case lookupCtxt Nothing n (idris_datatypes i) of + [v] -> return f { ibc_datatypes = (n,v): ibc_datatypes f } + _ -> fail "IBC write failed" +ibc i (IBCOpt n) f = case lookupCtxt Nothing n (idris_optimisation i) of + [v] -> return f { ibc_optimise = (n,v): ibc_optimise f } + _ -> fail "IBC write failed" +ibc i (IBCSyntax n) f = return f { ibc_syntax = n : ibc_syntax f } +ibc i (IBCKeyword n) f = return f { ibc_keywords = n : ibc_keywords f } +ibc i (IBCImport n) f = return f { ibc_imports = n : ibc_imports f } +ibc i (IBCObj n) f = return f { ibc_objs = n : ibc_objs f } +ibc i (IBCLib n) f = return f { ibc_libs = n : ibc_libs f } +ibc i (IBCHeader n) f = return f { ibc_hdrs = n : ibc_hdrs f } +ibc i (IBCDef n) f = case lookupDef Nothing n (tt_ctxt i) of + [v] -> return f { ibc_defs = (n,v) : ibc_defs f } + _ -> fail "IBC write failed" +ibc i (IBCAccess n a) f = return f { ibc_access = (n,a) : ibc_access f } + +process :: IBCFile -> FilePath -> Idris () +process i fn + | ver i /= ibcVersion = do iLOG "ibc out of date" + fail "Incorrect ibc version" + | otherwise = + do srcok <- liftIO $ doesFileExist (sourcefile i) + when srcok $ liftIO $ timestampOlder (sourcefile i) fn + v <- verbose + when (v && srcok) $ iputStrLn $ "Skipping " ++ sourcefile i + pImports (ibc_imports i) + pImps (ibc_implicits i) + pFixes (ibc_fixes i) + pStatics (ibc_statics i) + pClasses (ibc_classes i) + pDatatypes (ibc_datatypes i) + pOptimise (ibc_optimise i) + pSyntax (ibc_syntax i) + pKeywords (ibc_keywords i) + pObjs (ibc_objs i) + pLibs (ibc_libs i) + pHdrs (ibc_hdrs i) + pDefs (ibc_defs i) + pAccess (ibc_access i) + +timestampOlder :: FilePath -> FilePath -> IO () +timestampOlder src ibc = do srct <- getModificationTime src + ibct <- getModificationTime ibc + if (srct > ibct) + then fail "Needs reloading" + else return () + +pImports :: [FilePath] -> Idris () +pImports fs + = do datadir <- liftIO $ getDataDir + mapM_ (\f -> do fp <- liftIO $ findImport [".", datadir] f + i <- getIState + if (f `elem` imported i) + then iLOG $ "Already read " ++ f + else do putIState (i { imported = f : imported i }) + case fp of + LIDR fn -> do iLOG $ "Failed at " ++ fn + fail "Must be an ibc" + IDR fn -> do iLOG $ "Failed at " ++ fn + fail "Must be an ibc" + IBC fn src -> loadIBC fn) + fs + +pImps :: [(Name, [PArg])] -> Idris () +pImps imps = mapM_ (\ (n, imp) -> + do i <- getIState + putIState (i { idris_implicits + = addDef n imp (idris_implicits i) })) + imps + +pFixes :: [FixDecl] -> Idris () +pFixes f = do i <- getIState + putIState (i { idris_infixes = f ++ idris_infixes i }) + +pStatics :: [(Name, [Bool])] -> Idris () +pStatics ss = mapM_ (\ (n, s) -> + do i <- getIState + putIState (i { idris_statics + = addDef n s (idris_statics i) })) + ss + +pClasses :: [(Name, ClassInfo)] -> Idris () +pClasses cs = mapM_ (\ (n, c) -> + do i <- getIState + putIState (i { idris_classes + = addDef n c (idris_classes i) })) + cs + +pDatatypes :: [(Name, TypeInfo)] -> Idris () +pDatatypes cs = mapM_ (\ (n, c) -> + do i <- getIState + putIState (i { idris_datatypes + = addDef n c (idris_datatypes i) })) + cs + +pOptimise :: [(Name, OptInfo)] -> Idris () +pOptimise cs = mapM_ (\ (n, c) -> + do i <- getIState + putIState (i { idris_optimisation + = addDef n c (idris_optimisation i) })) + cs + +pSyntax :: [Syntax] -> Idris () +pSyntax s = do i <- getIState + putIState (i { syntax_rules = s ++ syntax_rules i }) + +pKeywords :: [String] -> Idris () +pKeywords k = do i <- getIState + putIState (i { syntax_keywords = k ++ syntax_keywords i }) + +pObjs :: [FilePath] -> Idris () +pObjs os = mapM_ addObjectFile os + +pLibs :: [String] -> Idris () +pLibs ls = mapM_ addLib ls + +pHdrs :: [String] -> Idris () +pHdrs hs = mapM_ addHdr hs + +pDefs :: [(Name, Def)] -> Idris () +pDefs ds = mapM_ (\ (n, d) -> + do i <- getIState + logLvl 5 $ "Added " ++ show (n, d) + putIState (i { tt_ctxt = addCtxtDef n d (tt_ctxt i) })) + ds + +pAccess :: [(Name, Accessibility)] -> Idris () +pAccess ds = mapM_ (\ (n, a) -> + do i <- getIState + putIState (i { tt_ctxt = setAccess n a (tt_ctxt i) })) + ds + +----- Generated by 'derive' + + +instance Binary FC where + put (FC x1 x2) + = do put x1 + put x2 + get + = do x1 <- get + x2 <- get + return (FC x1 x2) + + +instance Binary Name where + put x + = case x of + UN x1 -> do putWord8 0 + put x1 + NS x1 x2 -> do putWord8 1 + put x1 + put x2 + MN x1 x2 -> do putWord8 2 + put x1 + put x2 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + return (UN x1) + 1 -> do x1 <- get + x2 <- get + return (NS x1 x2) + 2 -> do x1 <- get + x2 <- get + return (MN x1 x2) + _ -> error "Corrupted binary data for Name" + + +instance Binary Const where + put x + = case x of + I x1 -> do putWord8 0 + put x1 + BI x1 -> do putWord8 1 + put x1 + Fl x1 -> do putWord8 2 + put x1 + Ch x1 -> do putWord8 3 + put x1 + Str x1 -> do putWord8 4 + put x1 + IType -> putWord8 5 + BIType -> putWord8 6 + FlType -> putWord8 7 + ChType -> putWord8 8 + StrType -> putWord8 9 + PtrType -> putWord8 10 + Forgot -> putWord8 11 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + return (I x1) + 1 -> do x1 <- get + return (BI x1) + 2 -> do x1 <- get + return (Fl x1) + 3 -> do x1 <- get + return (Ch x1) + 4 -> do x1 <- get + return (Str x1) + 5 -> return IType + 6 -> return BIType + 7 -> return FlType + 8 -> return ChType + 9 -> return StrType + 10 -> return PtrType + 11 -> return Forgot + _ -> error "Corrupted binary data for Const" + + +instance Binary Raw where + put x + = case x of + Var x1 -> do putWord8 0 + put x1 + RBind x1 x2 x3 -> do putWord8 1 + put x1 + put x2 + put x3 + RApp x1 x2 -> do putWord8 2 + put x1 + put x2 + RSet -> putWord8 3 + RConstant x1 -> do putWord8 4 + put x1 + RForce x1 -> do putWord8 5 + put x1 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + return (Var x1) + 1 -> do x1 <- get + x2 <- get + x3 <- get + return (RBind x1 x2 x3) + 2 -> do x1 <- get + x2 <- get + return (RApp x1 x2) + 3 -> return RSet + 4 -> do x1 <- get + return (RConstant x1) + 5 -> do x1 <- get + return (RForce x1) + _ -> error "Corrupted binary data for Raw" + + +instance (Binary b) => Binary (Binder b) where + put x + = case x of + Lam x1 -> do putWord8 0 + put x1 + Pi x1 -> do putWord8 1 + put x1 + Let x1 x2 -> do putWord8 2 + put x1 + put x2 + NLet x1 x2 -> do putWord8 3 + put x1 + put x2 + Hole x1 -> do putWord8 4 + put x1 + GHole x1 -> do putWord8 5 + put x1 + Guess x1 x2 -> do putWord8 6 + put x1 + put x2 + PVar x1 -> do putWord8 7 + put x1 + PVTy x1 -> do putWord8 8 + put x1 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + return (Lam x1) + 1 -> do x1 <- get + return (Pi x1) + 2 -> do x1 <- get + x2 <- get + return (Let x1 x2) + 3 -> do x1 <- get + x2 <- get + return (NLet x1 x2) + 4 -> do x1 <- get + return (Hole x1) + 5 -> do x1 <- get + return (GHole x1) + 6 -> do x1 <- get + x2 <- get + return (Guess x1 x2) + 7 -> do x1 <- get + return (PVar x1) + 8 -> do x1 <- get + return (PVTy x1) + _ -> error "Corrupted binary data for Binder" + + +instance Binary NameType where + put x + = case x of + Bound -> putWord8 0 + Ref -> putWord8 1 + DCon x1 x2 -> do putWord8 2 + put x1 + put x2 + TCon x1 x2 -> do putWord8 3 + put x1 + put x2 + get + = do i <- getWord8 + case i of + 0 -> return Bound + 1 -> return Ref + 2 -> do x1 <- get + x2 <- get + return (DCon x1 x2) + 3 -> do x1 <- get + x2 <- get + return (TCon x1 x2) + _ -> error "Corrupted binary data for NameType" + + +instance (Binary n) => Binary (TT n) where + put x + = case x of + P x1 x2 x3 -> do putWord8 0 + put x1 + put x2 + put x3 + V x1 -> do putWord8 1 + put x1 + Bind x1 x2 x3 -> do putWord8 2 + put x1 + put x2 + put x3 + App x1 x2 -> do putWord8 3 + put x1 + put x2 + Constant x1 -> do putWord8 4 + put x1 + Set x1 -> do putWord8 5 + put x1 + Erased -> do putWord8 6 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + x2 <- get + x3 <- get + return (P x1 x2 x3) + 1 -> do x1 <- get + return (V x1) + 2 -> do x1 <- get + x2 <- get + x3 <- get + return (Bind x1 x2 x3) + 3 -> do x1 <- get + x2 <- get + return (App x1 x2) + 4 -> do x1 <- get + return (Constant x1) + 5 -> do x1 <- get + return (Set x1) + 6 -> return Erased + _ -> error "Corrupted binary data for TT" + + +instance Binary SC where + put x + = case x of + Case x1 x2 -> do putWord8 0 + put x1 + put x2 + STerm x1 -> do putWord8 1 + put x1 + UnmatchedCase x1 -> do putWord8 2 + put x1 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + x2 <- get + return (Case x1 x2) + 1 -> do x1 <- get + return (STerm x1) + 2 -> do x1 <- get + return (UnmatchedCase x1) + _ -> error "Corrupted binary data for SC" + + +instance Binary CaseAlt where + put x + = case x of + ConCase x1 x2 x3 x4 -> do putWord8 0 + put x1 + put x2 + put x3 + put x4 + ConstCase x1 x2 -> do putWord8 1 + put x1 + put x2 + DefaultCase x1 -> do putWord8 2 + put x1 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + x2 <- get + x3 <- get + x4 <- get + return (ConCase x1 x2 x3 x4) + 1 -> do x1 <- get + x2 <- get + return (ConstCase x1 x2) + 2 -> do x1 <- get + return (DefaultCase x1) + _ -> error "Corrupted binary data for CaseAlt" + + +instance Binary Def where + put x + = case x of + Function x1 x2 -> do putWord8 0 + put x1 + put x2 + TyDecl x1 x2 -> do putWord8 1 + put x1 + put x2 + Operator x1 x2 x3 -> do putWord8 2 + put x1 + put x2 + put x3 + CaseOp x1 x2 x3 x4 x5 x6 x7 -> do putWord8 3 + put x1 + put x2 + put x3 + put x4 + put x5 + put x6 + put x7 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + x2 <- get + return (Function x1 x2) + 1 -> do x1 <- get + x2 <- get + return (TyDecl x1 x2) + 2 -> do x1 <- get + x2 <- get + x3 <- get + return (Operator x1 x2 x3) + 3 -> do x1 <- get + x2 <- get + x3 <- get + x4 <- get + x5 <- get + x6 <- get + x7 <- get + return (CaseOp x1 x2 x3 x4 x5 x6 x7) + _ -> error "Corrupted binary data for Def" + +instance Binary Accessibility where + put x + = case x of + Public -> putWord8 0 + Frozen -> putWord8 1 + Hidden -> putWord8 2 + get + = do i <- getWord8 + case i of + 0 -> return Public + 1 -> return Frozen + 2 -> return Hidden + _ -> error "Corrupted binary data for Accessibility" + +instance Binary IBCFile where + put (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16) + = do put x1 + put x2 + put x3 + put x4 + put x5 + put x6 + put x7 + put x8 + put x9 + put x10 + put x11 + put x12 + put x13 + put x14 + put x15 + put x16 + get + = do x1 <- get + if x1 == ibcVersion then + do x2 <- get + x3 <- get + x4 <- get + x5 <- get + x6 <- get + x7 <- get + x8 <- get + x9 <- get + x10 <- get + x11 <- get + x12 <- get + x13 <- get + x14 <- get + x15 <- get + x16 <- get + return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16) + else return (initIBC { ver = x1 }) + +instance Binary Fixity where + put x + = case x of + Infixl x1 -> do putWord8 0 + put x1 + Infixr x1 -> do putWord8 1 + put x1 + InfixN x1 -> do putWord8 2 + put x1 + PrefixN x1 -> do putWord8 3 + put x1 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + return (Infixl x1) + 1 -> do x1 <- get + return (Infixr x1) + 2 -> do x1 <- get + return (InfixN x1) + 3 -> do x1 <- get + return (PrefixN x1) + _ -> error "Corrupted binary data for Fixity" + + +instance Binary FixDecl where + put (Fix x1 x2) + = do put x1 + put x2 + get + = do x1 <- get + x2 <- get + return (Fix x1 x2) + + +instance Binary Static where + put x + = case x of + Static -> putWord8 0 + Dynamic -> putWord8 1 + get + = do i <- getWord8 + case i of + 0 -> return Static + 1 -> return Dynamic + _ -> error "Corrupted binary data for Static" + + +instance Binary Plicity where + put x + = case x of + Imp x1 x2 -> do putWord8 0 + put x1 + put x2 + Exp x1 x2 -> do putWord8 1 + put x1 + put x2 + Constraint x1 x2 -> do putWord8 2 + put x1 + put x2 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + x2 <- get + return (Imp x1 x2) + 1 -> do x1 <- get + x2 <- get + return (Exp x1 x2) + 2 -> do x1 <- get + x2 <- get + return (Constraint x1 x2) + _ -> error "Corrupted binary data for Plicity" + + +instance Binary PTerm where + put x + = case x of + PQuote x1 -> do putWord8 0 + put x1 + PRef x1 x2 -> do putWord8 1 + put x1 + put x2 + PLam x1 x2 x3 -> do putWord8 2 + put x1 + put x2 + put x3 + PPi x1 x2 x3 x4 -> do putWord8 3 + put x1 + put x2 + put x3 + put x4 + PLet x1 x2 x3 x4 -> do putWord8 4 + put x1 + put x2 + put x3 + put x4 + PApp x1 x2 x3 -> do putWord8 5 + put x1 + put x2 + put x3 + PTrue x1 -> do putWord8 6 + put x1 + PFalse x1 -> do putWord8 7 + put x1 + PRefl x1 -> do putWord8 8 + put x1 + PResolveTC x1 -> do putWord8 9 + put x1 + PEq x1 x2 x3 -> do putWord8 10 + put x1 + put x2 + put x3 + PPair x1 x2 x3 -> do putWord8 11 + put x1 + put x2 + put x3 + PDPair x1 x2 x3 x4 -> do putWord8 12 + put x1 + put x2 + put x3 + put x4 + PAlternative x1 -> do putWord8 13 + put x1 + PHidden x1 -> do putWord8 14 + put x1 + PSet -> putWord8 15 + PConstant x1 -> do putWord8 16 + put x1 + Placeholder -> putWord8 17 + PDoBlock x1 -> do putWord8 18 + put x1 + PReturn x1 -> do putWord8 19 + put x1 + PMetavar x1 -> do putWord8 20 + put x1 + PProof x1 -> do putWord8 21 + put x1 + PTactics x1 -> do putWord8 22 + put x1 + PElabError x1 -> do putWord8 23 + put x1 + PImpossible -> putWord8 24 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + return (PQuote x1) + 1 -> do x1 <- get + x2 <- get + return (PRef x1 x2) + 2 -> do x1 <- get + x2 <- get + x3 <- get + return (PLam x1 x2 x3) + 3 -> do x1 <- get + x2 <- get + x3 <- get + x4 <- get + return (PPi x1 x2 x3 x4) + 4 -> do x1 <- get + x2 <- get + x3 <- get + x4 <- get + return (PLet x1 x2 x3 x4) + 5 -> do x1 <- get + x2 <- get + x3 <- get + return (PApp x1 x2 x3) + 6 -> do x1 <- get + return (PTrue x1) + 7 -> do x1 <- get + return (PFalse x1) + 8 -> do x1 <- get + return (PRefl x1) + 9 -> do x1 <- get + return (PResolveTC x1) + 10 -> do x1 <- get + x2 <- get + x3 <- get + return (PEq x1 x2 x3) + 11 -> do x1 <- get + x2 <- get + x3 <- get + return (PPair x1 x2 x3) + 12 -> do x1 <- get + x2 <- get + x3 <- get + x4 <- get + return (PDPair x1 x2 x3 x4) + 13 -> do x1 <- get + return (PAlternative x1) + 14 -> do x1 <- get + return (PHidden x1) + 15 -> return PSet + 16 -> do x1 <- get + return (PConstant x1) + 17 -> return Placeholder + 18 -> do x1 <- get + return (PDoBlock x1) + 19 -> do x1 <- get + return (PReturn x1) + 20 -> do x1 <- get + return (PMetavar x1) + 21 -> do x1 <- get + return (PProof x1) + 22 -> do x1 <- get + return (PTactics x1) + 23 -> do x1 <- get + return (PElabError x1) + 24 -> return PImpossible + _ -> error "Corrupted binary data for PTerm" + + +instance (Binary t) => Binary (PTactic' t) where + put x + = case x of + Intro x1 -> do putWord8 0 + put x1 + Focus x1 -> do putWord8 1 + put x1 + Refine x1 x2 -> do putWord8 2 + put x1 + put x2 + Rewrite x1 -> do putWord8 3 + put x1 + LetTac x1 x2 -> do putWord8 4 + put x1 + put x2 + Exact x1 -> do putWord8 5 + put x1 + Compute -> putWord8 6 + Trivial -> putWord8 7 + Solve -> putWord8 8 + Attack -> putWord8 9 + ProofState -> putWord8 10 + ProofTerm -> putWord8 11 + Undo -> putWord8 12 + Try x1 x2 -> do putWord8 13 + put x1 + put x2 + TSeq x1 x2 -> do putWord8 14 + put x1 + put x2 + Qed -> putWord8 15 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + return (Intro x1) + 1 -> do x1 <- get + return (Focus x1) + 2 -> do x1 <- get + x2 <- get + return (Refine x1 x2) + 3 -> do x1 <- get + return (Rewrite x1) + 4 -> do x1 <- get + x2 <- get + return (LetTac x1 x2) + 5 -> do x1 <- get + return (Exact x1) + 6 -> return Compute + 7 -> return Trivial + 8 -> return Solve + 9 -> return Attack + 10 -> return ProofState + 11 -> return ProofTerm + 12 -> return Undo + 13 -> do x1 <- get + x2 <- get + return (Try x1 x2) + 14 -> do x1 <- get + x2 <- get + return (TSeq x1 x2) + 15 -> return Qed + _ -> error "Corrupted binary data for PTactic'" + + +instance (Binary t) => Binary (PDo' t) where + put x + = case x of + DoExp x1 x2 -> do putWord8 0 + put x1 + put x2 + DoBind x1 x2 x3 -> do putWord8 1 + put x1 + put x2 + put x3 + DoBindP x1 x2 x3 -> do putWord8 2 + put x1 + put x2 + put x3 + DoLet x1 x2 x3 x4 -> do putWord8 3 + put x1 + put x2 + put x3 + put x4 + DoLetP x1 x2 x3 -> do putWord8 4 + put x1 + put x2 + put x3 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + x2 <- get + return (DoExp x1 x2) + 1 -> do x1 <- get + x2 <- get + x3 <- get + return (DoBind x1 x2 x3) + 2 -> do x1 <- get + x2 <- get + x3 <- get + return (DoBindP x1 x2 x3) + 3 -> do x1 <- get + x2 <- get + x3 <- get + x4 <- get + return (DoLet x1 x2 x3 x4) + 4 -> do x1 <- get + x2 <- get + x3 <- get + return (DoLetP x1 x2 x3) + _ -> error "Corrupted binary data for PDo'" + + +instance (Binary t) => Binary (PArg' t) where + put x + = case x of + PImp x1 x2 x3 x4 -> do putWord8 0 + put x1 + put x2 + put x3 + put x4 + PExp x1 x2 x3 -> do putWord8 1 + put x1 + put x2 + put x3 + PConstraint x1 x2 x3 -> do putWord8 2 + put x1 + put x2 + put x3 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + x2 <- get + x3 <- get + x4 <- get + return (PImp x1 x2 x3 x4) + 1 -> do x1 <- get + x2 <- get + x3 <- get + return (PExp x1 x2 x3) + 2 -> do x1 <- get + x2 <- get + x3 <- get + return (PConstraint x1 x2 x3) + _ -> error "Corrupted binary data for PArg'" + + +instance Binary ClassInfo where + put (CI x1 x2 x3 x4) + = do put x1 + put x2 + put x3 + put x4 + get + = do x1 <- get + x2 <- get + x3 <- get + x4 <- get + return (CI x1 x2 x3 x4) + +instance Binary OptInfo where + put (Optimise x1 x2 x3) + = do put x1 + put x2 + put x3 + get + = do x1 <- get + x2 <- get + x3 <- get + return (Optimise x1 x2 x3) + +instance Binary TypeInfo where + put (TI x1) = put x1 + get = do x1 <- get + return (TI x1) + +instance Binary SynContext where + put x + = case x of + PatternSyntax -> putWord8 0 + TermSyntax -> putWord8 1 + AnySyntax -> putWord8 2 + get + = do i <- getWord8 + case i of + 0 -> return PatternSyntax + 1 -> return TermSyntax + 2 -> return AnySyntax + _ -> error "Corrupted binary data for SynContext" + + +instance Binary Syntax where + put (Rule x1 x2 x3) + = do put x1 + put x2 + put x3 + get + = do x1 <- get + x2 <- get + x3 <- get + return (Rule x1 x2 x3) + + +instance Binary SSymbol where + put x + = case x of + Keyword x1 -> do putWord8 0 + put x1 + Symbol x1 -> do putWord8 1 + put x1 + Expr x1 -> do putWord8 2 + put x1 + get + = do i <- getWord8 + case i of + 0 -> do x1 <- get + return (Keyword x1) + 1 -> do x1 <- get + return (Symbol x1) + 2 -> do x1 <- get + return (Expr x1) + _ -> error "Corrupted binary data for SSymbol" diff --git a/src/Idris/Imports.hs b/src/Idris/Imports.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Imports.hs @@ -0,0 +1,59 @@ +module Idris.Imports where + +import Idris.AbsSyntax + +import Core.TT +import Paths_idris + +import System.FilePath +import System.Directory +import Control.Monad.State + +data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType + deriving Eq + +srcPath :: FilePath -> FilePath +srcPath fp = let (n, ext) = splitExtension fp in + case ext of + ".idr" -> fp + _ -> fp ++ ".idr" + +lsrcPath :: FilePath -> FilePath +lsrcPath fp = let (n, ext) = splitExtension fp in + case ext of + ".lidr" -> fp + _ -> fp ++ ".lidr" + +-- Get name of byte compiled version of an import +ibcPath :: FilePath -> FilePath +ibcPath fp = let (n, ext) = splitExtension fp in + n ++ ".ibc" + +findImport :: [FilePath] -> FilePath -> IO IFileType +findImport [] fp = fail $ "Can't find import " ++ fp +findImport (d:ds) fp = do let ibcp = ibcPath (d ++ "/" ++ fp) + let idrp = srcPath (d ++ "/" ++ fp) + let lidrp = lsrcPath (d ++ "/" ++ fp) + ibc <- doesFileExist ibcp + idr <- doesFileExist idrp + lidr <- doesFileExist lidrp +-- when idr $ putStrLn $ idrp ++ " ok" +-- when lidr $ putStrLn $ lidrp ++ " ok" +-- when ibc $ putStrLn $ ibcp ++ " ok" + let isrc = if lidr then LIDR lidrp + else IDR idrp + if ibc + then return (IBC ibcp isrc) + else if (idr || lidr) + then return isrc + else findImport ds fp + +-- find a specific filename somewhere in a path + +findInPath :: [FilePath] -> FilePath -> IO FilePath +findInPath [] fp = fail $ "Can't find file " ++ fp +findInPath (d:ds) fp = do let p = d ++ "/" ++ fp + e <- doesFileExist p + if e then return p else findInPath ds p + + diff --git a/src/Idris/Parser.hs b/src/Idris/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Parser.hs @@ -0,0 +1,1219 @@ +module Idris.Parser where + +import Idris.AbsSyntax +import Idris.Imports +import Idris.Error +import Idris.ElabDecls +import Idris.ElabTerm +import Idris.IBC +import Idris.Unlit +import Paths_idris + +import Core.CoreParser +import Core.TT +import Core.Evaluate + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Error +import Text.ParserCombinators.Parsec.Expr +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as PTok + +import Data.List +import Control.Monad.State +import Debug.Trace +import Data.Maybe +import System.FilePath + +type TokenParser a = PTok.TokenParser a + +type IParser = GenParser Char IState + +lexer :: TokenParser IState +lexer = PTok.makeTokenParser idrisDef + +whiteSpace= PTok.whiteSpace lexer +lexeme = PTok.lexeme lexer +symbol = PTok.symbol lexer +natural = PTok.natural lexer +parens = PTok.parens lexer +semi = PTok.semi lexer +comma = PTok.comma lexer +identifier= PTok.identifier lexer +reserved = PTok.reserved lexer +operator = PTok.operator lexer +reservedOp= PTok.reservedOp lexer +integer = PTok.integer lexer +float = PTok.float lexer +strlit = PTok.stringLiteral lexer +chlit = PTok.charLiteral lexer +lchar = lexeme.char + +-- Loading modules + +loadModule :: FilePath -> Idris String +loadModule f + = idrisCatch (do datadir <- liftIO $ getDataDir + fp <- liftIO $ findImport [".", datadir] f + i <- getIState + if (f `elem` imported i) + then iLOG $ "Already read " ++ f + else do putIState (i { imported = f : imported i }) + case fp of + IDR fn -> loadSource False fn + LIDR fn -> loadSource True fn + IBC fn src -> + idrisCatch (loadIBC fn) + (\c -> do iLOG $ fn ++ " failed " ++ show c + case src of + IDR sfn -> loadSource False sfn + LIDR sfn -> loadSource True sfn) + let (dir, fh) = splitFileName f + return (dropExtension fh)) + (\e -> do let msg = show e + setErrLine (getErrLine msg) + iputStrLn msg + return "") + +loadSource :: Bool -> FilePath -> Idris () +loadSource lidr f + = do iLOG ("Reading " ++ f) + file_in <- liftIO $ readFile f + file <- if lidr then tclift $ unlit f file_in else return file_in + (mname, modules, rest, pos) <- parseImports f file + i <- getIState + putIState (i { default_access = Hidden }) + mapM_ loadModule modules + clearIBC -- start a new .ibc file + mapM_ (\m -> addIBC (IBCImport m)) modules + ds' <- parseProg (defaultSyntax {syn_namespace = reverse mname }) + f rest pos + let ds = namespaces mname ds' + logLvl 3 (dumpDecls ds) + i <- getIState + logLvl 10 (show (toAlist (idris_implicits i))) + logLvl 3 (show (idris_infixes i)) + -- Now add all the declarations to the context + v <- verbose + when v $ iputStrLn $ "Type checking " ++ f + mapM_ (elabDecl toplevel) ds + iLOG ("Finished " ++ f) + let ibc = dropExtension f ++ ".ibc" + iucheck + i <- getIState + addHides (hide_list i) + ok <- noErrors + when ok $ + idrisCatch (do writeIBC f ibc; clearIBC) + (\c -> return ()) -- failure is harmless + putIState (i { hide_list = [] }) + return () + where + namespaces [] ds = ds + namespaces (x:xs) ds = [PNamespace x (namespaces xs ds)] + +addHides :: [(Name, Maybe Accessibility)] -> Idris () +addHides xs = do i <- getIState + let defh = default_access i + let (hs, as) = partition isNothing xs + if null as then return () + else mapM_ doHide + (map (\ (n, _) -> (n, defh)) hs ++ + map (\ (n, Just a) -> (n, a)) as) + where isNothing (_, Nothing) = True + isNothing _ = False + + doHide (n, a) = do setAccessibility n a + addIBC (IBCAccess n a) + +parseExpr i = runParser (pFullExpr defaultSyntax) i "(input)" +parseTac i = runParser (do t <- pTactic defaultSyntax + eof + return t) i "(proof)" + +parseImports :: FilePath -> String -> Idris ([String], [String], String, SourcePos) +parseImports fname input + = do i <- get + case (runParser (do mname <- pHeader + ps <- many pImport + rest <- getInput + pos <- getPosition + return ((mname, ps, rest, pos), i)) i fname input) of + Left err -> fail (ishow err) + Right (x, i) -> do put i + return x + where ishow err = let ln = sourceLine (errorPos err) in + fname ++ ":" ++ show ln ++ ":parse error" +-- show (map messageString (errorMessages err)) + +pHeader :: IParser [String] +pHeader = try (do reserved "module"; i <- identifier; option ';' (lchar ';') + return (parseName i)) + <|> return [] + where parseName x = case span (/='.') x of + (x, "") -> [x] + (x, '.':y) -> x : parseName y + +push_indent :: IParser () +push_indent = do pos <- getPosition + ist <- getState + setState (ist { indent_stack = sourceColumn pos : + indent_stack ist }) + +last_indent :: IParser Int +last_indent = do ist <- getState + case indent_stack ist of + (x : xs) -> return x + _ -> return 1 + +indent :: IParser Int +indent = do pos <- getPosition + return (sourceColumn pos) + +pop_indent :: IParser () +pop_indent = do ist <- getState + let (x : xs) = indent_stack ist + setState (ist { indent_stack = xs }) + +open_block :: IParser () +open_block = do lchar '{' + ist <- getState + setState (ist { brace_stack = Nothing : brace_stack ist }) + <|> do ist <- getState + lvl <- indent + setState (ist { brace_stack = Just lvl : brace_stack ist }) + +close_block :: IParser () +close_block = do ist <- getState + bs <- case brace_stack ist of + Nothing : xs -> do lchar '}' + return xs + Just lvl : xs -> do i <- indent + inp <- getInput +-- trace (show (take 10 inp, i, lvl)) $ + if (i >= lvl && take 1 inp /= ")") + then fail "Not end of block" + else return xs + setState (ist { brace_stack = bs }) + +pTerminator = do lchar ';'; pop_indent + <|> do c <- indent; l <- last_indent + if (c <= l) then pop_indent + else fail "Not a terminator" + <|> do i <- getInput; if (take 1 i == "}" || take 1 i == ")") then pop_indent + else fail "Not a terminator" + <|> lookAhead eof + +pBarTerminator + = do lchar '|'; return () + <|> do c <- indent; l <- last_indent + if (c <= l) then return () + else fail "Not a terminator" + <|> lookAhead eof + +pKeepTerminator + = do lchar ';'; return () + <|> do c <- indent; l <- last_indent + if (c <= l) then return () + else fail "Not a terminator" + <|> do i <- getInput; let h = take 1 i + if (h == "}" || h == ")" || h == "|") then return () + else fail "Not a terminator" + <|> lookAhead eof + +notEndApp = do c <- indent; l <- last_indent + i <- getInput + if (c <= l) then fail "Terminator" + else return () + +notEndBlock = do ist <- getState + case brace_stack ist of + Just lvl : xs -> do i <- indent + inp <- getInput + if (i < lvl || take 1 inp == ")") + then fail "End of block" + else return () + _ -> return () + +pfc :: IParser FC +pfc = do s <- getPosition + let (dir, file) = splitFileName (sourceName s) + let f = case dir of + "./" -> file + _ -> sourceName s + return $ FC f (sourceLine s) + +pImport :: IParser String +pImport = do reserved "import" + f <- identifier + option ';' (lchar ';') + return (map dot f) + where dot '.' = '/' + dot c = c + +parseProg :: SyntaxInfo -> FilePath -> String -> SourcePos -> Idris [PDecl] +parseProg syn fname input pos + = do i <- get + case (runParser (do setPosition pos + whiteSpace + ps <- many (pDecl syn) + eof + i' <- getState + return (concat ps, i')) i fname input) of + Left err -> fail (ishow err) + Right (x, i) -> do put i + return (collect x) + where ishow err = let ln = sourceLine (errorPos err) in + fname ++ ":" ++ show ln ++ ":parse error" + ++ " at column " ++ show (sourceColumn (errorPos err)) +-- show (map messageString (errorMessages err)) + +-- Collect PClauses with the same function name + +collect :: [PDecl] -> [PDecl] +collect (c@(PClauses _ o _ _) : ds) + = clauses (cname c) [] (c : ds) + where clauses n acc (PClauses fc _ _ [PClause n' l ws r w] : ds) + | n == n' = clauses n (PClause n' l ws r (collect w) : acc) ds + clauses n acc (PClauses fc _ _ [PWith n' l ws r w] : ds) + | n == n' = clauses n (PWith n' l ws r (collect w) : acc) ds + clauses n acc xs = PClauses (getfc c) o n (reverse acc) : collect xs + + cname (PClauses fc _ _ [PClause n _ _ _ _]) = n + cname (PClauses fc _ _ [PWith n _ _ _ _]) = n + getfc (PClauses fc _ _ _) = fc + +collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds +collect (PNamespace ns ps : ds) = PNamespace ns (collect ps) : collect ds +collect (PClass f s cs n ps ds : ds') = PClass f s cs n ps (collect ds) : collect ds' +collect (PInstance f s cs n ps t ds : ds') + = PInstance f s cs n ps t (collect ds) : collect ds' +collect (d : ds) = d : collect ds +collect [] = [] + +pFullExpr :: SyntaxInfo -> IParser PTerm +pFullExpr syn + = do x <- pExpr syn; eof; + i <- getState + return $ desugar syn i x + +pDecl :: SyntaxInfo -> IParser [PDecl] +pDecl syn = do notEndBlock + pDeclBody where + pDeclBody + = do d <- pDecl' syn + i <- getState + let d' = fmap (desugar syn i) d + return [d'] + <|> pUsing syn + <|> pParams syn + <|> pNamespace syn + <|> pClass syn + <|> pInstance syn + <|> pDirective + <|> try (do reserved "import" + fp <- identifier + lchar ';' + fail "imports must be at the top of file") + +pFunDecl :: SyntaxInfo -> IParser [PDecl] +pFunDecl syn + = try (do notEndBlock + d <- pFunDecl' syn + i <- getState + let d' = fmap (desugar syn i) d + return [d']) + +--------- Top Level Declarations --------- + +pDecl' :: SyntaxInfo -> IParser PDecl +pDecl' syn + = try pFixity + <|> pFunDecl' syn + <|> try (pData syn) + <|> pSyntaxDecl syn + +pSyntaxDecl :: SyntaxInfo -> IParser PDecl +pSyntaxDecl syn + = do s <- pSyntaxRule syn + i <- getState + let rs = syntax_rules i + let ns = syntax_keywords i + let ibc = ibc_write i + let ks = map show (names s) + setState (i { syntax_rules = s : rs, + syntax_keywords = ks ++ ns, + ibc_write = IBCSyntax s : map IBCKeyword ks ++ ibc + }) + fc <- pfc + return (PSyntax fc s) + where + names (Rule syms _ _) = mapMaybe ename syms + ename (Keyword n) = Just n + ename _ = Nothing + +pSyntaxRule :: SyntaxInfo -> IParser Syntax +pSyntaxRule syn + = do push_indent + sty <- option AnySyntax (do reserved "term"; return TermSyntax + <|> do reserved "pattern"; return PatternSyntax) + reserved "syntax" + syms <- many1 pSynSym + when (all expr syms) $ fail "No keywords in syntax rule" + let ns = mapMaybe name syms + when (length ns /= length (nub ns)) + $ fail "Repeated variable in syntax rule" + lchar '=' + tm <- pExpr syn + pTerminator + return (Rule syms tm sty) + where + expr (Expr _) = True + expr _ = False + name (Expr n) = Just n + name _ = Nothing + +pSynSym :: IParser SSymbol +pSynSym = try (do lchar '['; n <- pName; lchar ']' + return (Expr n)) + <|> do n <- iName [] + return (Keyword n) + <|> do sym <- strlit + return (Symbol sym) + +pFunDecl' :: SyntaxInfo -> IParser PDecl +pFunDecl' syn = try (do push_indent + acc <- pAccessibility + n_in <- pfName + let n = expandNS syn n_in + ty <- pTSig syn + fc <- pfc + pTerminator +-- ty' <- implicit syn n ty + addAcc n acc + return (PTy syn fc n ty)) + <|> try (pPattern syn) + +pUsing :: SyntaxInfo -> IParser [PDecl] +pUsing syn = + do reserved "using"; + lchar '(' + ns <- tyDeclList syn + lchar ')' + open_block + let uvars = using syn + ds <- many1 (pDecl (syn { using = uvars ++ ns })) + close_block + return (concat ds) + +pParams :: SyntaxInfo -> IParser [PDecl] +pParams syn = + do reserved "params"; + lchar '(' + ns <- tyDeclList syn + lchar ')' + lchar '{' + let pvars = syn_params syn + ds <- many1 (pDecl syn { syn_params = pvars ++ ns }) + lchar '}' + fc <- pfc + return [PParams fc ns (concat ds)] + +pNamespace :: SyntaxInfo -> IParser [PDecl] +pNamespace syn = + do reserved "namespace"; + n <- identifier + open_block + ds <- many1 (pDecl syn { syn_namespace = n : syn_namespace syn }) + close_block + return [PNamespace n (concat ds)] + +expandNS :: SyntaxInfo -> Name -> Name +expandNS syn n@(NS _ _) = n +expandNS syn n = case syn_namespace syn of + [] -> n + xs -> NS n xs + +--------- Fixity --------- + +pFixity :: IParser PDecl +pFixity = do push_indent + f <- fixity; i <- natural; ops <- sepBy1 operator (lchar ',') + pTerminator + let prec = fromInteger i + istate <- getState + let fs = map (Fix (f prec)) ops + setState (istate { + idris_infixes = sort (fs ++ idris_infixes istate), + ibc_write = map IBCFix fs ++ ibc_write istate }) + fc <- pfc + return (PFix fc (f prec) ops) + +fixity :: IParser (Int -> Fixity) +fixity = try (do reserved "infixl"; return Infixl) + <|> try (do reserved "infixr"; return Infixr) + <|> try (do reserved "infix"; return InfixN) + <|> try (do reserved "prefix"; return PrefixN) + +--------- Tyoe classes --------- + +pClass :: SyntaxInfo -> IParser [PDecl] +pClass syn = do acc <- pAccessibility + reserved "class" + fc <- pfc + cons <- pConstList syn + n_in <- pName; let n = expandNS syn n_in + cs <- many1 carg + reserved "where"; open_block + ds <- many1 $ pFunDecl syn + close_block + let allDs = concat ds + accData acc n (concatMap declared allDs) + return [PClass syn fc cons n cs allDs] + where + carg = do lchar '('; i <- pName; lchar ':'; ty <- pExpr syn; lchar ')' + return (i, ty) + <|> do i <- pName; + return (i, PSet) + +pInstance :: SyntaxInfo -> IParser [PDecl] +pInstance syn = do reserved "instance" + fc <- pfc + cs <- pConstList syn + cn <- pName + args <- many1 (pSimpleExpr syn) + let sc = PApp fc (PRef fc cn) (map pexp args) + let t = bindList (PPi constraint) (map (\x -> (MN 0 "c", x)) cs) sc + reserved "where"; open_block + ds <- many1 $ pFunDecl syn + close_block + return [PInstance syn fc cs cn args t (concat ds)] + +--------- Expressions --------- + +pExpr syn = do i <- getState + buildExpressionParser (table (idris_infixes i)) (pExpr' syn) + +pExpr' :: SyntaxInfo -> IParser PTerm +pExpr' syn + = try (pExtExpr syn) + <|> pNoExtExpr syn + +pExtExpr :: SyntaxInfo -> IParser PTerm +pExtExpr syn = do i <- getState + pExtensions syn (syntax_rules i) + +pSimpleExtExpr :: SyntaxInfo -> IParser PTerm +pSimpleExtExpr syn = do i <- getState + pExtensions syn (filter simple (syntax_rules i)) + where + simple (Rule (Expr x:xs) _ _) = False + simple (Rule [Keyword _] _ _) = True + simple (Rule [Symbol _] _ _) = True + simple (Rule (_:xs) _ _) = case (last xs) of + Keyword _ -> True + Symbol _ -> True + _ -> False + simple _ = False + +pNoExtExpr syn = + try (pApp syn) + <|> try (pSimpleExpr syn) + <|> pLambda syn + <|> pLet syn + <|> pPi syn + <|> pDoBlock syn + <|> pComprehension syn + +pExtensions :: SyntaxInfo -> [Syntax] -> IParser PTerm +pExtensions syn rules = choice (map (\x -> try (pExt syn x)) (filter valid rules)) + where + valid (Rule _ _ AnySyntax) = True + valid (Rule _ _ PatternSyntax) = inPattern syn + valid (Rule _ _ TermSyntax) = not (inPattern syn) + + +pExt :: SyntaxInfo -> Syntax -> IParser PTerm +pExt syn (Rule (s:ssym) ptm _) + = do s1 <- pSymbol pSimpleExpr s + smap <- mapM (pSymbol pExpr) ssym + let ns = mapMaybe id (s1:smap) + return (update ns ptm) -- updated with smap + where + pSymbol p (Keyword n) = do reserved (show n); return Nothing + pSymbol p (Expr n) = do tm <- p syn + return $ Just (n, tm) + pSymbol p (Symbol s) = do symbol s + return Nothing + dropn n [] = [] + dropn n ((x,t) : xs) | n == x = xs + | otherwise = (x,t):dropn n xs + + update ns (PRef fc n) = case lookup n ns of + Just t -> t + _ -> PRef fc n + update ns (PLam n ty sc) = PLam n (update ns ty) (update (dropn n ns) sc) + update ns (PPi p n ty sc) = PPi p n (update ns ty) (update (dropn n ns) sc) + update ns (PLet n ty val sc) = PLet n (update ns ty) (update ns val) + (update (dropn n ns) sc) + update ns (PApp fc t args) = PApp fc (update ns t) (map (fmap (update ns)) args) + update ns (PCase fc c opts) = PCase fc (update ns c) (map (pmap (update ns)) opts) + update ns (PPair fc l r) = PPair fc (update ns l) (update ns r) + update ns (PDPair fc l t r) = PDPair fc (update ns l) (update ns t) (update ns r) + update ns (PAlternative as) = PAlternative (map (update ns) as) + update ns (PHidden t) = PHidden (update ns t) + update ns (PDoBlock ds) = PDoBlock $ upd ns ds + where upd ns (DoExp fc t : ds) = DoExp fc (update ns t) : upd ns ds + upd ns (DoBind fc n t : ds) = DoBind fc n (update ns t) : upd (dropn n ns) ds + upd ns (DoLet fc n ty t : ds) = DoLet fc n (update ns ty) (update ns t) + : upd (dropn n ns) ds + upd ns (DoBindP fc i t : ds) = DoBindP fc (update ns i) (update ns t) + : upd ns ds + upd ns (DoLetP fc i t : ds) = DoLetP fc (update ns i) (update ns t) + : upd ns ds + update ns t = t + +pName = do i <- getState + iName (syntax_keywords i) + <|> do reserved "instance" + i <- getState + UN n <- iName (syntax_keywords i) + return (UN ('@':n)) + + +pfName = try pName + <|> do lchar '('; o <- operator; lchar ')'; return (UN o) + +pAccessibility' :: IParser Accessibility +pAccessibility' + = do reserved "public"; return Public + <|> do reserved "abstract"; return Frozen + <|> do reserved "private"; return Hidden + +pAccessibility :: IParser (Maybe Accessibility) +pAccessibility + = do acc <- pAccessibility'; return (Just acc) + <|> return Nothing + +addAcc :: Name -> Maybe Accessibility -> IParser () +addAcc n a = do i <- getState + setState (i { hide_list = (n, a) : hide_list i }) + +pSimpleExpr syn = + try (do symbol "!["; t <- pTerm; lchar ']' + return $ PQuote t) + <|> do lchar '?'; x <- pName; return (PMetavar x) + <|> do reserved "refl"; fc <- pfc; return (PRefl fc) +-- <|> do reserved "return"; fc <- pfc; return (PReturn fc) + <|> do reserved "proof"; lchar '{'; + ts <- endBy (pTactic syn) (lchar ';') + lchar '}' + return (PProof ts) + <|> do reserved "tactics"; lchar '{'; + ts <- endBy (pTactic syn) (lchar ';') + lchar '}' + return (PTactics ts) + <|> do reserved "case"; fc <- pfc; scr <- pExpr syn; reserved "of"; + open_block + push_indent + opts <- many1 (do notEndBlock + x <- pCaseOpt syn + pKeepTerminator + return x) -- sepBy1 (pCaseOpt syn) (lchar '|') + pop_indent + close_block + return (PCase fc scr opts) + <|> try (do x <- pfName; fc <- pfc; return (PRef fc x)) + <|> try (pList syn) + <|> try (pAlt syn) + <|> try (pIdiom syn) + <|> try (do lchar '('; bracketed syn) + <|> try (do c <- pConstant; fc <- pfc + return (modifyConst syn fc (PConstant c))) + <|> do reserved "Set"; return PSet + <|> try (do symbol "()"; fc <- pfc; return (PTrue fc)) + <|> try (do symbol "_|_"; fc <- pfc; return (PFalse fc)) + <|> do lchar '_'; return Placeholder + <|> pSimpleExtExpr syn + +bracketed syn = + try (pPair syn) + <|> try (do e <- pExpr syn; lchar ')'; return e) + <|> try (do fc <- pfc; o <- operator; e <- pExpr syn; lchar ')' + return $ PLam (MN 0 "x") Placeholder + (PApp fc (PRef fc (UN o)) [pexp (PRef fc (MN 0 "x")), + pexp e])) + <|> try (do fc <- pfc; e <- pSimpleExpr syn; o <- operator; lchar ')' + return $ PLam (MN 0 "x") Placeholder + (PApp fc (PRef fc (UN o)) [pexp e, + pexp (PRef fc (MN 0 "x"))])) + +pCaseOpt :: SyntaxInfo -> IParser (PTerm, PTerm) +pCaseOpt syn = do lhs <- pExpr syn; symbol "=>"; + rhs <- pExpr syn + return (lhs, rhs) + +modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm +modifyConst syn fc (PConstant (I x)) + | not (inPattern syn) + = PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (I x))] +modifyConst syn fc x = x + +pList syn = do lchar '['; fc <- pfc + xs <- sepBy (pExpr syn) (lchar ','); lchar ']' + return (mkList fc xs) + where + mkList fc [] = PRef fc (UN "Nil") + mkList fc (x : xs) = PApp fc (PRef fc (UN "::")) [pexp x, pexp (mkList fc xs)] + +pPair syn = try (do l <- pExpr syn + fc <- pfc + rest <- restTuple + case rest of + [] -> return l + [Left r] -> return (PPair fc l r) + [Right r] -> return (PDPair fc l Placeholder r)) + <|> try (do x <- ntuple + lchar ')' + return x) + <|> do ln <- pName; lchar ':'; lty <- pExpr syn; + reservedOp "**"; + fc <- pfc + r <- pExpr syn; lchar ')'; + return (PDPair fc (PRef fc ln) lty r) + where + restTuple = do lchar ')'; return [] + <|> do lchar ',' + r <- pExpr syn + lchar ')' + return [Left r] + <|> do reservedOp "**" + r <- pExpr syn + lchar ')' + return [Right r] + ntuple = try (do l <- pExpr syn; fc <- pfc; lchar ',' + rest <- ntuple + return (PPair fc l rest)) + <|> (do l <- pExpr syn; fc <- pfc; lchar ',' + r <- pExpr syn + return (PPair fc l r)) + +pAlt syn = do symbol "(|"; + alts <- sepBy1 (pExpr' syn) (lchar ',') + symbol "|)" + return (PAlternative alts) + +pHSimpleExpr syn + = do lchar '.' + e <- pSimpleExpr syn + return $ PHidden e + <|> pSimpleExpr syn + +pApp syn = do f <- pSimpleExpr syn + fc <- pfc + args <- many1 (do notEndApp + pArg syn) + return (PApp fc f args) + +pArg :: SyntaxInfo -> IParser PArg +pArg syn = try (pImplicitArg syn) + <|> try (pConstraintArg syn) + <|> do e <- pSimpleExpr syn + return (pexp e) + +pImplicitArg syn = do lchar '{'; n <- pName + fc <- pfc + v <- option (PRef fc n) (do lchar '='; pExpr syn) + lchar '}' + return (pimp n v) + +pConstraintArg syn = do symbol "@{"; e <- pExpr syn; symbol "}" + return (pconst e) + +pTSig syn = do lchar ':' + cs <- pConstList syn + sc <- pExpr syn + return (bindList (PPi constraint) (map (\x -> (MN 0 "c", x)) cs) sc) + +pLambda syn = do lchar '\\' + (try (do xt <- tyOptDeclList syn + symbol "=>" + sc <- pExpr syn + return (bindList PLam xt sc)) + <|> (do ps <- sepBy (do fc <- pfc + e <- pSimpleExpr syn + return (fc, e)) (lchar ',') + symbol "=>" + sc <- pExpr syn + return (pmList (zip [0..] ps) sc))) + where pmList [] sc = sc + pmList ((i, (fc, x)) : xs) sc + = PLam (MN i "lamp") Placeholder + (PCase fc (PRef fc (MN i "lamp")) + [(x, (pmList xs sc))]) + +pLet syn = try (do reserved "let"; n <- pName; + ty <- option Placeholder (do lchar ':'; pExpr' syn) + lchar '='; v <- pExpr syn + reserved "in"; sc <- pExpr syn + return (PLet n ty v sc)) + <|> (do reserved "let"; fc <- pfc; pat <- pExpr' syn + symbol "="; v <- pExpr syn + reserved "in"; sc <- pExpr syn + return (PCase fc v [(pat, sc)])) + +pPi syn = + try (do lazy <- option False (do lchar '|'; return True) + st <- pStatic + lchar '('; xt <- tyDeclList syn; lchar ')' + symbol "->" + sc <- pExpr syn + return (bindList (PPi (Exp lazy st)) xt sc)) + <|> try (do lazy <- option False (do lchar '|'; return True) + st <- pStatic + lchar '{'; xt <- tyDeclList syn; lchar '}' + symbol "->" + sc <- pExpr syn + return (bindList (PPi (Imp lazy st)) xt sc)) + <|> do --lazy <- option False (do lchar '|'; return True) + lchar '{'; reserved "static"; lchar '}' + t <- pExpr' syn + symbol "->" + sc <- pExpr syn + return (PPi (Exp False Static) (MN 42 "__pi_arg") t sc) + +pConstList :: SyntaxInfo -> IParser [PTerm] +pConstList syn = try (do lchar '(' + tys <- sepBy1 (pExpr' syn) (lchar ',') + lchar ')' + reservedOp "=>" + return tys) + <|> try (do t <- pExpr syn + reservedOp "=>" + return [t]) + <|> return [] + +tyDeclList syn = try (sepBy1 (do x <- pfName; t <- pTSig syn; return (x,t)) + (lchar ',')) + <|> do ns <- sepBy1 pName (lchar ',') + t <- pTSig syn + return (map (\x -> (x, t)) ns) + +tyOptDeclList syn = sepBy1 (do x <- pfName; + t <- option Placeholder (do lchar ':' + pExpr syn) + return (x,t)) + (lchar ',') + +bindList b [] sc = sc +bindList b ((n, t):bs) sc = b n t (bindList b bs sc) + +pComprehension syn + = do lchar '['; fc <- pfc; pat <- pExpr syn; lchar '|'; + qs <- sepBy1 (pDo syn) (lchar ','); lchar ']'; + return (PDoBlock (map addGuard qs ++ + [DoExp fc (PApp fc (PRef fc (UN "return")) + [pexp pat])])) + where addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc (UN "guard")) + [pexp e]) + addGuard x = x + +pDoBlock syn + = do reserved "do"; open_block + push_indent + ds <- many1 (do notEndBlock + x <- pDo syn; pKeepTerminator; return x) + pop_indent + close_block + return (PDoBlock ds) + +pDo syn + = try (do reserved "let"; i <- pName; + ty <- option Placeholder (do lchar ':'; pExpr' syn) + reservedOp "="; fc <- pfc + e <- pExpr syn + return (DoLet fc i ty e)) + <|> try (do reserved "let"; i <- pExpr' syn; reservedOp "="; fc <- pfc + sc <- pExpr syn + return (DoLetP fc i sc)) + <|> try (do i <- pName; symbol "<-"; fc <- pfc + e <- pExpr syn; + return (DoBind fc i e)) + <|> try (do i <- pExpr' syn; symbol "<-"; fc <- pfc + e <- pExpr syn; + return (DoBindP fc i e)) + <|> try (do e <- pExpr syn; fc <- pfc + return (DoExp fc e)) + +pIdiom syn + = do symbol "[|"; fc <- pfc; e <- pExpr syn; symbol "|]" + return (PIdiom fc e) + +pConstant :: IParser Const +pConstant = do reserved "Integer";return BIType + <|> do reserved "Int"; return IType + <|> do reserved "Char"; return ChType + <|> do reserved "Float"; return FlType + <|> do reserved "String"; return StrType + <|> do reserved "Ptr"; return PtrType + <|> try (do f <- float; return $ Fl f) + <|> try (do i <- natural; lchar 'L'; return $ BI i) + <|> try (do i <- natural; return $ I (fromInteger i)) + <|> try (do s <- strlit; return $ Str s) + <|> try (do c <- chlit; return $ Ch c) + +pStatic :: IParser Static +pStatic = do lchar '['; reserved "static"; lchar ']'; + return Static + <|> return Dynamic + +table fixes + = [[prefix "-" (\fc x -> PApp fc (PRef fc (UN "-")) + [pexp (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (I 0))]), pexp x])]] + ++ toTable (reverse fixes) ++ + [[binary "=" (\fc x y -> PEq fc x y) AssocLeft], + [binary "->" (\fc x y -> PPi expl (MN 42 "__pi_arg") x y) AssocRight]] + +toTable fs = map (map toBin) + (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs) + where toBin (Fix (PrefixN _) op) = prefix op + (\fc x -> PApp fc (PRef fc (UN op)) [pexp x]) + toBin (Fix f op) + = binary op (\fc x y -> PApp fc (PRef fc (UN op)) [pexp x,pexp y]) (assoc f) + assoc (Infixl _) = AssocLeft + assoc (Infixr _) = AssocRight + assoc (InfixN _) = AssocNone + +binary name f assoc = Infix (do { reservedOp name; fc <- pfc; + return (f fc) }) assoc +prefix name f = Prefix (do { reservedOp name; fc <- pfc; + return (f fc) }) + +--------- Data declarations --------- + +-- (works for classes too - 'abstract' means the data/class is visible but members not) +accData :: Maybe Accessibility -> Name -> [Name] -> IParser () +accData (Just Frozen) n ns = do addAcc n (Just Frozen) + mapM_ (\n -> addAcc n (Just Hidden)) ns +accData a n ns = do addAcc n a; mapM_ (\n -> addAcc n a) ns + +pData :: SyntaxInfo -> IParser PDecl +pData syn = try (do acc <- pAccessibility + reserved "data"; fc <- pfc + tyn_in <- pfName; ty <- pTSig syn + let tyn = expandNS syn tyn_in + reserved "where" + open_block + push_indent + cons <- many (do notEndBlock + c <- pConstructor syn + pKeepTerminator + return c) -- (lchar '|') + pop_indent + close_block + accData acc tyn (map (\ (n, _, _) -> n) cons) + return $ PData syn fc (PDatadecl tyn ty cons)) + <|> try (do push_indent + acc <- pAccessibility + reserved "data"; fc <- pfc + tyn_in <- pfName; args <- many pName + let tyn = expandNS syn tyn_in + lchar '=' + cons <- sepBy1 (pSimpleCon syn) (lchar '|') + pTerminator + let conty = mkPApp fc (PRef fc tyn) (map (PRef fc) args) + let ty = bindArgs (map (\a -> PSet) args) PSet + cons' <- mapM (\ (x, cargs, cfc) -> + do let cty = bindArgs cargs conty + return (x, cty, cfc)) cons + accData acc tyn (map (\ (n, _, _) -> n) cons') + return $ PData syn fc (PDatadecl tyn ty cons')) + where + mkPApp fc t [] = t + mkPApp fc t xs = PApp fc t (map pexp xs) + +bindArgs :: [PTerm] -> PTerm -> PTerm +bindArgs [] t = t +bindArgs (x:xs) t = PPi expl (MN 0 "t") x (bindArgs xs t) + +pConstructor :: SyntaxInfo -> IParser (Name, PTerm, FC) +pConstructor syn + = do cn_in <- pfName; fc <- pfc + let cn = expandNS syn cn_in + ty <- pTSig syn +-- ty' <- implicit syn cn ty + return (cn, ty, fc) + +pSimpleCon :: SyntaxInfo -> IParser (Name, [PTerm], FC) +pSimpleCon syn + = do cn_in <- pfName + let cn = expandNS syn cn_in + fc <- pfc + args <- many (do notEndApp + pSimpleExpr syn) + return (cn, args, fc) + +--------- Pattern match clauses --------- + +pPattern :: SyntaxInfo -> IParser PDecl +pPattern syn = do clause <- pClause syn + fc <- pfc + return (PClauses fc [] (MN 2 "_") [clause]) -- collect together later + +pArgExpr syn = let syn' = syn { inPattern = True } in + try (pHSimpleExpr syn') <|> pSimpleExtExpr syn' + +pRHS :: SyntaxInfo -> Name -> IParser PTerm +pRHS syn n = do lchar '='; pExpr syn + <|> do symbol "?="; rhs <- pExpr syn; + return (PLet (UN "value") Placeholder rhs (PMetavar n')) + <|> do reserved "impossible"; return PImpossible + where mkN (UN x) = UN (x++"_lemma_1") + mkN (NS x n) = NS (mkN x) n + n' = mkN n + +pClause :: SyntaxInfo -> IParser PClause +pClause syn + = try (do push_indent + n_in <- pfName; let n = expandNS syn n_in + cargs <- many (pConstraintArg syn) + iargs <- many (pImplicitArg syn) + fc <- pfc + args <- many (pArgExpr syn) + wargs <- many (pWExpr syn) + rhs <- pRHS syn n + ist <- getState + let ctxt = tt_ctxt ist + let wsyn = syn { syn_namespace = [] } + (wheres, nmap) <- choice [do x <- pWhereblock n wsyn + pop_indent + return x, + do pTerminator + return ([], [])] + let capp = PApp fc (PRef fc n) + (iargs ++ cargs ++ map pexp args) + ist <- getState + setState (ist { lastParse = Just n }) + return $ PClause n capp wargs rhs wheres) + <|> try (do push_indent + wargs <- many1 (pWExpr syn) + ist <- getState + n <- case lastParse ist of + Just t -> return t + Nothing -> fail "Invalid clause" + rhs <- pRHS syn n + let ctxt = tt_ctxt ist + let wsyn = syn { syn_namespace = [] } + (wheres, nmap) <- choice [do x <- pWhereblock n wsyn + pop_indent + return x, + do pTerminator + return ([], [])] + return $ PClauseR wargs rhs wheres) + + <|> try (do push_indent + n_in <- pfName; let n = expandNS syn n_in + cargs <- many (pConstraintArg syn) + iargs <- many (pImplicitArg syn) + fc <- pfc + args <- many (pArgExpr syn) + wargs <- many (pWExpr syn) + let capp = PApp fc (PRef fc n) + (iargs ++ cargs ++ map pexp args) + reserved "with" + wval <- pSimpleExpr syn + open_block + ds <- many1 $ pFunDecl syn + let withs = map (fillLHSD n capp wargs) $ concat ds + close_block + ist <- getState + setState (ist { lastParse = Just n }) + pop_indent + return $ PWith n capp wargs wval withs) + + <|> try (do wargs <- many1 (pWExpr syn) + reserved "with" + wval <- pSimpleExpr syn + open_block + ds <- many1 $ pFunDecl syn + let withs = concat ds + close_block + return $ PWithR wargs wval withs) + + <|> do push_indent + l <- pArgExpr syn + op <- operator + let n = expandNS syn (UN op) + r <- pArgExpr syn + fc <- pfc + wargs <- many (pWExpr syn) + rhs <- pRHS syn n + let wsyn = syn { syn_namespace = [] } + (wheres, nmap) <- choice [do x <- pWhereblock n wsyn + pop_indent + return x, + do pTerminator + return ([], [])] + ist <- getState + let capp = PApp fc (PRef fc n) [pexp l, pexp r] + setState (ist { lastParse = Just n }) + return $ PClause n capp wargs rhs wheres + + <|> do l <- pArgExpr syn + op <- operator + let n = expandNS syn (UN op) + r <- pArgExpr syn + fc <- pfc + wargs <- many (pWExpr syn) + reserved "with" + wval <- pSimpleExpr syn + open_block + ds <- many1 $ pFunDecl syn + close_block + ist <- getState + let capp = PApp fc (PRef fc n) [pexp l, pexp r] + let withs = map (fillLHSD n capp wargs) $ concat ds + setState (ist { lastParse = Just n }) + return $ PWith n capp wargs wval withs + where + fillLHS n capp owargs (PClauseR wargs v ws) + = PClause n capp (owargs ++ wargs) v ws + fillLHS n capp owargs (PWithR wargs v ws) + = PWith n capp (owargs ++ wargs) v + (map (fillLHSD n capp (owargs ++ wargs)) ws) + fillLHS _ _ _ c = c + + fillLHSD n c a (PClauses fc o fn cs) = PClauses fc o fn (map (fillLHS n c a) cs) + fillLHSD n c a x = x + +pWExpr :: SyntaxInfo -> IParser PTerm +pWExpr syn = do lchar '|'; pExpr' syn + +pWhereblock :: Name -> SyntaxInfo -> IParser ([PDecl], [(Name, Name)]) +pWhereblock n syn + = do reserved "where"; open_block + ds <- many1 $ pFunDecl syn + let dns = concatMap (concatMap declared) ds + close_block + return (concat ds, map (\x -> (x, decoration syn x)) dns) + +pDirective :: IParser [PDecl] +pDirective = try (do lchar '%'; reserved "lib"; lib <- strlit; + return [PDirective (do addLib lib + addIBC (IBCLib lib))]) + <|> try (do lchar '%'; reserved "link"; obj <- strlit; + return [PDirective (do datadir <- liftIO $ getDataDir + o <- liftIO $ findInPath [".", datadir] obj + addIBC (IBCObj o) + addObjectFile o)]) + <|> try (do lchar '%'; reserved "include"; hdr <- strlit; + return [PDirective (do addHdr hdr + addIBC (IBCHeader hdr))]) + <|> try (do lchar '%'; reserved "hide"; n <- iName [] + return [PDirective (do setAccessibility n Hidden + addIBC (IBCAccess n Hidden))]) + <|> try (do lchar '%'; reserved "freeze"; n <- iName [] + return [PDirective (do setAccessibility n Frozen + addIBC (IBCAccess n Frozen))]) + <|> try (do lchar '%'; reserved "access"; acc <- pAccessibility' + return [PDirective (do i <- getIState + putIState (i { default_access = acc }))]) + <|> do lchar '%'; reserved "logging"; i <- natural; + return [PDirective (setLogLevel (fromInteger i))] + +pTactic :: SyntaxInfo -> IParser PTactic +pTactic syn = do reserved "intro"; ns <- sepBy pName (lchar ',') + return $ Intro ns + <|> do reserved "intros"; return Intros + <|> try (do reserved "refine"; n <- pName + imps <- many1 imp + return $ Refine n imps) + <|> do reserved "refine"; n <- pName + i <- getState + return $ Refine n [] + <|> do reserved "rewrite"; t <- pExpr syn; + i <- getState + return $ Rewrite (desugar syn i t) + <|> do reserved "let"; n <- pName; lchar '='; + t <- pExpr syn; + i <- getState + return $ LetTac n (desugar syn i t) + <|> do reserved "focus"; n <- pName + return $ Focus n + <|> do reserved "exact"; t <- pExpr syn; + i <- getState + return $ Exact (desugar syn i t) + <|> do reserved "try"; t <- pTactic syn; + lchar '|'; + t1 <- pTactic syn + return $ Try t t1 + <|> do lchar '{' + t <- pTactic syn; + lchar ';'; + t1 <- pTactic syn; + lchar '}' + return $ TSeq t t1 + <|> do reserved "compute"; return Compute + <|> do reserved "trivial"; return Trivial + <|> do reserved "solve"; return Solve + <|> do reserved "attack"; return Attack + <|> do reserved "state"; return ProofState + <|> do reserved "term"; return ProofTerm + <|> do reserved "undo"; return Undo + <|> do reserved "qed"; return Qed + where + imp = do lchar '?'; return False + <|> do lchar '_'; return True + +desugar :: SyntaxInfo -> IState -> PTerm -> PTerm +desugar syn i t = let t' = expandDo (dsl_info syn) t in + t' -- addImpl i t' + +expandDo :: DSL -> PTerm -> PTerm +expandDo dsl (PLam n ty tm) = PLam n (expandDo dsl ty) (expandDo dsl tm) +expandDo dsl (PLet n ty v tm) = PLet n (expandDo dsl ty) (expandDo dsl v) (expandDo dsl tm) +expandDo dsl (PPi p n ty tm) = PPi p n (expandDo dsl ty) (expandDo dsl tm) +expandDo dsl (PApp fc t args) = PApp fc (expandDo dsl t) + (map (fmap (expandDo dsl)) args) +expandDo dsl (PCase fc s opts) = PCase fc (expandDo dsl s) + (map (pmap (expandDo dsl)) opts) +expandDo dsl (PPair fc l r) = PPair fc (expandDo dsl l) (expandDo dsl r) +expandDo dsl (PDPair fc l t r) = PDPair fc (expandDo dsl l) (expandDo dsl t) + (expandDo dsl r) +expandDo dsl (PAlternative as) = PAlternative (map (expandDo dsl) as) +expandDo dsl (PHidden t) = PHidden (expandDo dsl t) +expandDo dsl (PReturn fc) = dsl_return dsl +expandDo dsl (PDoBlock ds) = expandDo dsl $ block (dsl_bind dsl) ds + where + block b [DoExp fc tm] = tm + block b [a] = PElabError "Last statement in do block must be an expression" + block b (DoBind fc n tm : rest) + = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))] + block b (DoBindP fc p tm : rest) + = PApp fc b [pexp tm, pexp (PLam (MN 0 "bpat") Placeholder + (PCase fc (PRef fc (MN 0 "bpat")) + [(p, block b rest)]))] + block b (DoLet fc n ty tm : rest) + = PLet n ty tm (block b rest) + block b (DoLetP fc p tm : rest) + = PCase fc tm [(p, block b rest)] + block b (DoExp fc tm : rest) + = PApp fc b + [pexp tm, + pexp (PLam (MN 0 "bindx") Placeholder (block b rest))] + block b _ = PElabError "Invalid statement in do block" +expandDo dsl (PIdiom fc e) = expandDo dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e +expandDo dsl t = t + +unIdiom :: PTerm -> PTerm -> FC -> PTerm -> PTerm +unIdiom ap pure fc e@(PApp _ _ _) = let f = getFn e in + mkap (getFn e) + where + getFn (PApp fc f args) = (PApp fc pure [pexp f], args) + getFn f = (f, []) + + mkap (f, []) = f + mkap (f, a:as) = mkap (PApp fc ap [pexp f, a], as) + +unIdiom ap pure fc e = PApp fc pure [pexp e] + diff --git a/src/Idris/Primitives.hs b/src/Idris/Primitives.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Primitives.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} + +module Idris.Primitives(elabPrims) where + +import Idris.ElabDecls +import Idris.ElabTerm +import Idris.AbsSyntax + +import Core.TT +import Core.Evaluate + +import Epic.Epic hiding (Term, Type, Name, fn) +import qualified Epic.Epic as E + +data Prim = Prim { p_name :: Name, + p_type :: Type, + p_arity :: Int, + p_def :: [Value] -> Maybe Value, + p_epic :: ([E.Name], E.Term) + } + +ty [] x = Constant x +ty (t:ts) x = Bind (MN 0 "T") (Pi (Constant t)) (ty ts x) + +believeTy = Bind (UN "a") (Pi (Set (UVar (-2)))) + (Bind (UN "b") (Pi (Set (UVar (-2)))) + (Bind (UN "x") (Pi (V 1)) (V 1))) + +type ETm = E.Term +type EOp = E.Op + +fun = E.fn +ref = E.ref + +eOp :: EOp -> ([E.Name], ETm) +eOp op = ([E.name "x", E.name "y"], E.op_ op (E.fn "x") (E.fn "y")) + +eOpFn :: E.Type -> E.Type -> String -> ([E.Name], ETm) +eOpFn ty rty op = ([E.name "x", E.name "y"], + foreign_ rty op [(E.fn "x", ty), (E.fn "y", ty)]) + +strToInt x = foreign_ tyInt "strToInt" [(x, tyString)] +intToStr x = foreign_ tyString "intToStr" [(x, tyInt)] +charToInt x = x +intToChar x = x +intToBigInt x = foreign_ tyBigInt "intToBigInt" [(x, tyInt)] +strToBigInt x = foreign_ tyBigInt "strToBig" [(x, tyString)] +bigIntToStr x = foreign_ tyString "bigToStr" [(x, tyBigInt)] +strToFloat x = foreign_ tyFloat "strToFloat" [(x, tyString)] +floatToStr x = foreign_ tyString "floatToStr" [(x, tyFloat)] +intToFloat x = foreign_ tyFloat "intToFloat" [(x, tyInt)] +floatToInt x = foreign_ tyInt "floatToInt" [(x, tyFloat)] + +floatExp x = foreign_ tyFloat "exp" [(x, tyFloat)] +floatLog x = foreign_ tyFloat "log" [(x, tyFloat)] +floatSin x = foreign_ tyFloat "sin" [(x, tyFloat)] +floatCos x = foreign_ tyFloat "cos" [(x, tyFloat)] +floatTan x = foreign_ tyFloat "tan" [(x, tyFloat)] +floatASin x = foreign_ tyFloat "asin" [(x, tyFloat)] +floatACos x = foreign_ tyFloat "acos" [(x, tyFloat)] +floatATan x = foreign_ tyFloat "atan" [(x, tyFloat)] +floatFloor x = foreign_ tyFloat "floor" [(x, tyFloat)] +floatCeil x = foreign_ tyFloat "ceil" [(x, tyFloat)] +floatSqrt x = foreign_ tyFloat "sqrt" [(x, tyFloat)] + +strIndex x i = foreign_ tyChar "strIndex" [(x, tyString), (i, tyInt)] +strHead x = foreign_ tyChar "strHead" [(x, tyString)] +strTail x = foreign_ tyString "strTail" [(x, tyString)] +strCons x xs = foreign_ tyString "strCons" [(x, tyChar), (xs, tyString)] +strRev x = foreign_ tyString "strrev" [(x, tyString)] +strEq x y = foreign_ tyInt "streq" [(x, tyString), (y, tyString)] +strLt x y = foreign_ tyInt "strlt" [(x, tyString), (y, tyString)] + +primitives = + -- operators + [Prim (UN "prim__addInt") (ty [IType, IType] IType) 2 (iBin (+)) + (eOp E.plus_), + Prim (UN "prim__subInt") (ty [IType, IType] IType) 2 (iBin (-)) + (eOp E.minus_), + Prim (UN "prim__mulInt") (ty [IType, IType] IType) 2 (iBin (*)) + (eOp E.times_), + Prim (UN "prim__divInt") (ty [IType, IType] IType) 2 (iBin (div)) + (eOp E.divide_), + Prim (UN "prim__eqInt") (ty [IType, IType] IType) 2 (biBin (==)) + (eOp E.eq_), + Prim (UN "prim__ltInt") (ty [IType, IType] IType) 2 (biBin (<)) + (eOp E.lt_), + Prim (UN "prim__lteInt") (ty [IType, IType] IType) 2 (biBin (<=)) + (eOp E.lte_), + Prim (UN "prim__gtInt") (ty [IType, IType] IType) 2 (biBin (>)) + (eOp E.gt_), + Prim (UN "prim__gteInt") (ty [IType, IType] IType) 2 (biBin (>=)) + (eOp E.gte_), + Prim (UN "prim__eqChar") (ty [ChType, ChType] IType) 2 (bcBin (==)) + (eOp E.eq_), + Prim (UN "prim__ltChar") (ty [ChType, ChType] IType) 2 (bcBin (<)) + (eOp E.lt_), + Prim (UN "prim__lteChar") (ty [ChType, ChType] IType) 2 (bcBin (<=)) + (eOp E.lte_), + Prim (UN "prim__gtChar") (ty [ChType, ChType] IType) 2 (bcBin (>)) + (eOp E.gt_), + Prim (UN "prim__gteChar") (ty [ChType, ChType] IType) 2 (bcBin (>=)) + (eOp E.gte_), + Prim (UN "prim__addBigInt") (ty [BIType, BIType] BIType) 2 (bBin (+)) + (eOpFn tyBigInt tyBigInt "addBig"), + Prim (UN "prim__subBigInt") (ty [BIType, BIType] BIType) 2 (bBin (-)) + (eOpFn tyBigInt tyBigInt "subBig"), + Prim (UN "prim__mulBigInt") (ty [BIType, BIType] BIType) 2 (bBin (*)) + (eOpFn tyBigInt tyBigInt "mulBig"), + Prim (UN "prim__divBigInt") (ty [BIType, BIType] BIType) 2 (bBin (div)) + (eOpFn tyBigInt tyBigInt "divBig"), + Prim (UN "prim__eqBigInt") (ty [BIType, BIType] IType) 2 (bbBin (==)) + (eOpFn tyBigInt tyInt "eqBig"), + Prim (UN "prim__ltBigInt") (ty [BIType, BIType] IType) 2 (bbBin (<)) + (eOpFn tyBigInt tyInt "ltBig"), + Prim (UN "prim__lteBigInt") (ty [BIType, BIType] IType) 2 (bbBin (<=)) + (eOpFn tyBigInt tyInt "leBig"), + Prim (UN "prim__gtBigInt") (ty [BIType, BIType] IType) 2 (bbBin (>)) + (eOpFn tyBigInt tyInt "gtBig"), + Prim (UN "prim__gtBigInt") (ty [BIType, BIType] IType) 2 (bbBin (>=)) + (eOpFn tyBigInt tyInt "geBig"), + Prim (UN "prim__addFloat") (ty [FlType, FlType] FlType) 2 (fBin (+)) + (eOp E.plusF_), + Prim (UN "prim__subFloat") (ty [FlType, FlType] FlType) 2 (fBin (-)) + (eOp E.minusF_), + Prim (UN "prim__mulFloat") (ty [FlType, FlType] FlType) 2 (fBin (*)) + (eOp E.timesF_), + Prim (UN "prim__divFloat") (ty [FlType, FlType] FlType) 2 (fBin (/)) + (eOp E.divideF_), + Prim (UN "prim__eqFloat") (ty [FlType, FlType] IType) 2 (bfBin (==)) + (eOp E.eqF_), + Prim (UN "prim__ltFloat") (ty [FlType, FlType] IType) 2 (bfBin (<)) + (eOp E.ltF_), + Prim (UN "prim__lteFloat") (ty [FlType, FlType] IType) 2 (bfBin (<=)) + (eOp E.lteF_), + Prim (UN "prim__gtFloat") (ty [FlType, FlType] IType) 2 (bfBin (>)) + (eOp E.gtF_), + Prim (UN "prim__gteFloat") (ty [FlType, FlType] IType) 2 (bfBin (>=)) + (eOp E.gteF_), + Prim (UN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++)) + ([E.name "x", E.name "y"], (fun "append") @@ fun "x" @@ fun "y"), + Prim (UN "prim__eqString") (ty [StrType, StrType] IType) 2 (bsBin (==)) + ([E.name "x", E.name "y"], strEq (fun "x") (fun "y")), + Prim (UN "prim__ltString") (ty [StrType, StrType] IType) 2 (bsBin (<)) + ([E.name "x", E.name "y"], strLt (fun "x") (fun "y")), + -- Conversions + Prim (UN "prim__strToInt") (ty [StrType] IType) 1 (c_strToInt) + ([E.name "x"], strToInt (fun "x")), + Prim (UN "prim__intToStr") (ty [IType] StrType) 1 (c_intToStr) + ([E.name "x"], intToStr (fun "x")), + Prim (UN "prim__charToInt") (ty [ChType] IType) 1 (c_charToInt) + ([E.name "x"], charToInt (fun "x")), + Prim (UN "prim__intToChar") (ty [IType] ChType) 1 (c_intToChar) + ([E.name "x"], intToChar (fun "x")), + Prim (UN "prim__intToBigInt") (ty [IType] BIType) 1 (c_intToBigInt) + ([E.name "x"], intToBigInt (fun "x")), + Prim (UN "prim__strToBigInt") (ty [StrType] BIType) 1 (c_strToBigInt) + ([E.name "x"], strToBigInt (fun "x")), + Prim (UN "prim__bigIntToStr") (ty [BIType] StrType) 1 (c_bigIntToStr) + ([E.name "x"], bigIntToStr (fun "x")), + Prim (UN "prim__strToFloat") (ty [StrType] FlType) 1 (c_strToFloat) + ([E.name "x"], strToFloat (fun "x")), + Prim (UN "prim__floatToStr") (ty [FlType] StrType) 1 (c_floatToStr) + ([E.name "x"], floatToStr (fun "x")), + Prim (UN "prim__intToFloat") (ty [IType] FlType) 1 (c_intToFloat) + ([E.name "x"], intToFloat (fun "x")), + Prim (UN "prim__floatToInt") (ty [FlType] IType) 1 (c_floatToInt) + ([E.name "x"], floatToInt (fun "x")), + + Prim (UN "prim__floatExp") (ty [FlType] FlType) 1 (p_floatExp) + ([E.name "x"], floatExp (fun "x")), + Prim (UN "prim__floatLog") (ty [FlType] FlType) 1 (p_floatLog) + ([E.name "x"], floatLog (fun "x")), + Prim (UN "prim__floatSin") (ty [FlType] FlType) 1 (p_floatSin) + ([E.name "x"], floatSin (fun "x")), + Prim (UN "prim__floatCos") (ty [FlType] FlType) 1 (p_floatCos) + ([E.name "x"], floatCos (fun "x")), + Prim (UN "prim__floatTan") (ty [FlType] FlType) 1 (p_floatTan) + ([E.name "x"], floatTan (fun "x")), + Prim (UN "prim__floatASin") (ty [FlType] FlType) 1 (p_floatASin) + ([E.name "x"], floatASin (fun "x")), + Prim (UN "prim__floatACos") (ty [FlType] FlType) 1 (p_floatACos) + ([E.name "x"], floatACos (fun "x")), + Prim (UN "prim__floatATan") (ty [FlType] FlType) 1 (p_floatATan) + ([E.name "x"], floatATan (fun "x")), + Prim (UN "prim__floatSqrt") (ty [FlType] FlType) 1 (p_floatSqrt) + ([E.name "x"], floatSqrt (fun "x")), + Prim (UN "prim__floatFloor") (ty [FlType] FlType) 1 (p_floatFloor) + ([E.name "x"], floatFloor (fun "x")), + Prim (UN "prim__floatCeil") (ty [FlType] FlType) 1 (p_floatCeil) + ([E.name "x"], floatCeil (fun "x")), + + Prim (UN "prim__strHead") (ty [StrType] ChType) 1 (p_strHead) + ([E.name "x"], strHead (fun "x")), + Prim (UN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail) + ([E.name "x"], strTail (fun "x")), + Prim (UN "prim__strCons") (ty [ChType, StrType] StrType) 2 (p_strCons) + ([E.name "x", E.name "xs"], strCons (fun "x") (fun "xs")), + Prim (UN "prim__strIndex") (ty [StrType, IType] ChType) 2 (p_strIndex) + ([E.name "x", E.name "i"], strIndex (fun "x") (fun "i")), + Prim (UN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev) + ([E.name "x"], strRev (fun "x")), + + Prim (UN "prim__believe_me") believeTy 3 (p_believeMe) + ([E.name "a", E.name "b", E.name "x"], fun "x") + ] + +p_believeMe [_,_,x] = Just x +p_believeMe _ = Nothing + +iBin op [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (op x y)) +iBin _ _ = Nothing + +bBin op [VConstant (BI x), VConstant (BI y)] = Just $ VConstant (BI (op x y)) +bBin _ _ = Nothing + +bBini op [VConstant (BI x), VConstant (BI y)] = Just $ VConstant (I (op x y)) +bBini _ _ = Nothing + +biBin op = iBin (\x y -> if (op x y) then 1 else 0) +bbBin op = bBini (\x y -> if (op x y) then 1 else 0) + +fBin op [VConstant (Fl x), VConstant (Fl y)] = Just $ VConstant (Fl (op x y)) +fBin _ _ = Nothing + +bfBin op [VConstant (Fl x), VConstant (Fl y)] = let i = (if op x y then 1 else 0) in + Just $ VConstant (I i) +bfBin _ _ = Nothing + +bcBin op [VConstant (Ch x), VConstant (Ch y)] = let i = (if op x y then 1 else 0) in + Just $ VConstant (I i) +bcBin _ _ = Nothing + +bsBin op [VConstant (Str x), VConstant (Str y)] + = let i = (if op x y then 1 else 0) in + Just $ VConstant (I i) +bsBin _ _ = Nothing + +sBin op [VConstant (Str x), VConstant (Str y)] = Just $ VConstant (Str (op x y)) +sBin _ _ = Nothing + +c_intToStr [VConstant (I x)] = Just $ VConstant (Str (show x)) +c_intToStr _ = Nothing +c_strToInt [VConstant (Str x)] = Just $ VConstant (I (read x)) +c_strToInt _ = Nothing + +c_intToChar [VConstant (I x)] = Just $ VConstant (Ch (toEnum x)) +c_intToChar _ = Nothing +c_charToInt [VConstant (Ch x)] = Just $ VConstant (I (fromEnum x)) +c_charToInt _ = Nothing + +c_intToBigInt [VConstant (I x)] = Just $ VConstant (BI (fromIntegral x)) +c_intToBigInt _ = Nothing + +c_bigIntToStr [VConstant (BI x)] = Just $ VConstant (Str (show x)) +c_bigIntToStr _ = Nothing +c_strToBigInt [VConstant (Str x)] = Just $ VConstant (BI (read x)) +c_strToBigInt _ = Nothing + +c_floatToStr [VConstant (Fl x)] = Just $ VConstant (Str (show x)) +c_floatToStr _ = Nothing +c_strToFloat [VConstant (Str x)] = Just $ VConstant (Fl (read x)) +c_strToFloat _ = Nothing + +c_floatToInt [VConstant (Fl x)] = Just $ VConstant (I (truncate x)) +c_floatToInt _ = Nothing + +c_intToFloat [VConstant (I x)] = Just $ VConstant (Fl (fromIntegral x)) +c_intToFloat _ = Nothing + +p_fPrim f [VConstant (Fl x)] = Just $ VConstant (Fl (f x)) +p_fPrim f _ = Nothing + +p_floatExp = p_fPrim exp +p_floatLog = p_fPrim log +p_floatSin = p_fPrim sin +p_floatCos = p_fPrim cos +p_floatTan = p_fPrim tan +p_floatASin = p_fPrim asin +p_floatACos = p_fPrim acos +p_floatATan = p_fPrim atan +p_floatSqrt = p_fPrim sqrt +p_floatFloor = p_fPrim (fromInteger . floor) +p_floatCeil = p_fPrim (fromInteger . ceiling) + +p_strHead [VConstant (Str (x:xs))] = Just $ VConstant (Ch x) +p_strHead _ = Nothing +p_strTail [VConstant (Str (x:xs))] = Just $ VConstant (Str xs) +p_strTail _ = Nothing +p_strIndex [VConstant (Str xs), VConstant (I i)] + | i < length xs = Just $ VConstant (Ch (xs!!i)) +p_strIndex _ = Nothing +p_strCons [VConstant (Ch x), VConstant (Str xs)] = Just $ VConstant (Str (x:xs)) +p_strCons _ = Nothing +p_strRev [VConstant (Str xs)] = Just $ VConstant (Str (reverse xs)) +p_strRev _ = Nothing + +elabPrim :: Prim -> Idris () +elabPrim (Prim n ty i def epic) + = do updateContext (addOperator n ty i def) + i <- getIState + putIState i { idris_prims = (n, epic) : idris_prims i } + +elabPrims :: Idris () +elabPrims = do mapM_ (elabDecl toplevel) + (map (PData defaultSyntax (FC "builtin" 0)) + [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]) + mapM_ elabPrim primitives + diff --git a/src/Idris/Prover.hs b/src/Idris/Prover.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Prover.hs @@ -0,0 +1,120 @@ +module Idris.Prover where + +import Core.Elaborate hiding (Tactic(..)) +import Core.TT +import Core.Evaluate +import Core.CaseTree +import Core.Typecheck + +import Idris.AbsSyntax +import Idris.Delaborate +import Idris.ElabDecls +import Idris.ElabTerm +import Idris.Parser +import Idris.Error +import Idris.DataOpts + +import System.Console.Haskeline +import Control.Monad.State + +prover :: Bool -> Name -> Idris () +prover lit x = + do ctxt <- getContext + i <- get + case lookupTy Nothing x ctxt of + [t] -> if elem x (idris_metavars i) + then prove ctxt lit x t + else fail $ show x ++ " is not a metavariable" + _ -> fail "No such metavariable" + +showProof :: Bool -> Name -> [String] -> String +showProof lit n ps + = bird ++ show n ++ " = proof {" ++ break ++ + showSep break (map (\x -> " " ++ x ++ ";") ps) ++ + break ++ "}\n" + where bird = if lit then "> " else "" + break = "\n" ++ bird + +prove :: Context -> Bool -> Name -> Type -> Idris () +prove ctxt lit n ty + = do let ps = initElaborator n ctxt ty + (tm, prf) <- ploop True ("-" ++ show n) [] (ES (ps, []) "" Nothing) + iLOG $ "Adding " ++ show tm + iputStrLn $ showProof lit n prf + i <- get + put (i { last_proof = Just (n, prf) }) + let tree = simpleCase False True [(P Ref n ty, tm)] + logLvl 3 (show tree) + (ptm, pty) <- recheckC ctxt (FC "proof" 0) [] tm + ptm' <- applyOpts ptm + updateContext (addCasedef n True False True [(P Ref n ty, ptm)] + [(P Ref n ty, ptm')] ty) + solveDeferred n +elabStep :: ElabState [PDecl] -> ElabD a -> Idris (a, ElabState [PDecl]) +elabStep st e = do case runStateT e st of + OK (a, st') -> return (a, st') + Error a -> do i <- get + fail (pshow i a) + +dumpState :: IState -> ProofState -> IO () +dumpState ist (PS nm [] _ tm _ _ _ _ _ _ _ _ _ _ _) = putStrLn $ (show nm) ++ ": no more goals" +dumpState ist ps@(PS nm (h:hs) _ tm _ _ _ _ problems i _ _ ctxy _ _) + = do let OK ty = goalAtFocus ps + let OK env = envAtFocus ps +-- putStrLn $ "Other goals: " ++ show hs ++ "\n" + putStr $ "\n" ++ showPs (reverse env) + putStrLn $ "---------------------------------- (" ++ show nm + ++ ") --------" + putStrLn $ show h ++ " : " ++ showG ty ++ "\n" + where + tshow t = show (delab ist t) + + showPs [] = "" + showPs ((MN _ "rewrite_rule", _) : bs) = showPs bs + showPs ((n, Let t v) : bs) + = " " ++ show n ++ " = " ++ tshow v ++ " : " ++ + tshow t ++ "\n" ++ showPs bs + showPs ((n, b) : bs) + = " " ++ show n ++ " : " ++ + tshow (binderTy b) ++ "\n" ++ showPs bs + + showG (Guess t v) = tshow t ++ " =?= " ++ tshow v + showG b = tshow (binderTy b) + +lifte :: ElabState [PDecl] -> ElabD a -> Idris a +lifte st e = do (v, _) <- elabStep st e + return v + +ploop :: Bool -> String -> [String] -> ElabState [PDecl] -> Idris (Term, [String]) +ploop d prompt prf e + = do i <- get + when d $ liftIO $ dumpState i (proof e) + x <- lift $ getInputLine (prompt ++ "> ") + (cmd, step) <- case x of + Nothing -> fail "Abandoned" + Just input -> do return (parseTac i input, input) + (d, st, done, prf') <- idrisCatch + (case cmd of + Left err -> do iputStrLn (show err) + return (False, e, False, prf) + Right Undo -> + do (_, st) <- elabStep e loadState + return (True, st, False, init prf) + Right ProofState -> + return (True, e, False, prf) + Right ProofTerm -> + do tm <- lifte e get_term + iputStrLn $ "TT: " ++ show tm ++ "\n" + return (False, e, False, prf) + Right Qed -> do hs <- lifte e get_holes + when (not (null hs)) $ fail "Incomplete proof" + return (False, e, True, prf) + Right tac -> do (_, e) <- elabStep e saveState + (_, st) <- elabStep e (runTac True i tac) + return (True, st, False, prf ++ [step])) + (\err -> do iputStrLn (show err) + return (False, e, False, prf)) + if done then do (tm, _) <- elabStep st get_term + return (tm, prf') + else ploop d prompt prf' st + diff --git a/src/Idris/REPL.hs b/src/Idris/REPL.hs new file mode 100644 --- /dev/null +++ b/src/Idris/REPL.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, + PatternGuards #-} + +module Idris.REPL where + +import Idris.AbsSyntax +import Idris.REPLParser +import Idris.ElabDecls +import Idris.ElabTerm +import Idris.Error +import Idris.Delaborate +import Idris.Compiler +import Idris.Prover +import Idris.Parser +import Paths_idris + +import Core.Evaluate +import Core.ProofShell +import Core.TT +import Core.Constraints + +import System.Console.Haskeline as H +import System.FilePath +import System.Environment +import System.Process +import System.Directory +import System.IO +import Control.Monad +import Control.Monad.State +import Data.List +import Data.Char +import Data.Version + +repl :: IState -> [FilePath] -> Idris () +repl orig mods + = H.catch + (do let prompt = mkPrompt mods + x <- lift $ getInputLine (prompt ++ "> ") + case x of + Nothing -> do iputStrLn "Bye bye" + return () + Just input -> H.catch + (do ms <- processInput input orig mods + case ms of + Just mods -> repl orig mods + Nothing -> return ()) + ctrlC) + ctrlC + where ctrlC :: SomeException -> Idris () + ctrlC e = do iputStrLn (show e) + repl orig mods + +mkPrompt [] = "Idris" +mkPrompt [x] = "*" ++ dropExtension x +mkPrompt (x:xs) = "*" ++ dropExtension x ++ " " ++ mkPrompt xs + +lit f = case splitExtension f of + (_, ".lidr") -> True + _ -> False + +processInput :: String -> IState -> [FilePath] -> Idris (Maybe [FilePath]) +processInput cmd orig inputs + = do i <- get + let fn = case inputs of + (f:_) -> f + _ -> "" + case parseCmd i cmd of + Left err -> do liftIO $ print err + return (Just inputs) + Right Reload -> do put (orig { idris_options = idris_options i }) + clearErr + mods <- mapM loadModule inputs + return (Just inputs) + Right Edit -> do edit fn orig + return (Just inputs) + Right AddProof -> do idrisCatch (addProof fn orig) + (\e -> iputStrLn (show e)) + return (Just inputs) + Right Quit -> do iputStrLn "Bye bye" + return Nothing + Right cmd -> do idrisCatch (process fn cmd) + (\e -> iputStrLn (show e)) + return (Just inputs) + +edit :: FilePath -> IState -> Idris () +edit "" orig = iputStrLn "Nothing to edit" +edit f orig + = do i <- get + env <- liftIO $ getEnvironment + let editor = getEditor env + let line = case errLine i of + Just l -> " +" ++ show l ++ " " + Nothing -> " " + let cmd = editor ++ line ++ f + liftIO $ system cmd + clearErr + put (orig { idris_options = idris_options i }) + loadModule f + iucheck + return () + where getEditor env | Just ed <- lookup "EDITOR" env = ed + | Just ed <- lookup "VISUAL" env = ed + | otherwise = "vi" + +addProof :: FilePath -> IState -> Idris () +addProof "" orig = iputStrLn "Nothing to add to" +addProof f orig + = do let fb = f ++ "~" + liftIO $ copyFile f fb -- make a backup in case something goes wrong! + prog <- liftIO $ readFile fb + i <- get + case last_proof i of + Nothing -> iputStrLn "No proof to add" + Just (n, p) -> do let prog' = insertScript (showProof (lit f) n p) (lines prog) + liftIO $ writeFile f (unlines prog') + iputStrLn $ "Added proof " ++ show n + put (i { last_proof = Nothing }) + -- lift $ removeFile fb -- uncomment when less scared :) + +insertScript :: String -> [String] -> [String] +insertScript prf [] = "\n---------- Proofs ----------" : "" : [prf] +insertScript prf (p@"---------- Proofs ----------" : "" : xs) + = p : "" : prf : xs +insertScript prf (x : xs) = x : insertScript prf xs + +process :: FilePath -> Command -> Idris () +process fn Help = iputStrLn displayHelp +process fn (Eval t) + = do (tm, ty) <- elabVal toplevel False t + ctxt <- getContext + ist <- get + let tm' = normaliseAll ctxt [] tm + let ty' = normaliseAll ctxt [] ty + logLvl 3 $ "Raw: " ++ show (tm', ty') + imp <- impShow + iputStrLn (showImp imp (delab ist tm') ++ " : " ++ + showImp imp (delab ist ty')) +process fn (ExecVal t) + = do (tm, ty) <- elabVal toplevel False t +-- (PApp fc (PRef fc (NS (UN "print") ["prelude"])) +-- [pexp t]) + (tmpn, tmph) <- liftIO tempfile + liftIO $ hClose tmph + compile tmpn tm + liftIO $ system tmpn + return () + where fc = FC "(input)" 0 +process fn (Check (PRef _ n)) + = do ctxt <- getContext + ist <- get + imp <- impShow + case lookupTy Nothing n ctxt of + [t] -> iputStrLn $ show n ++ " : " ++ + showImp imp (delab ist t) + _ -> iputStrLn $ "No such variable " ++ show n +process fn (Check t) = do (tm, ty) <- elabVal toplevel False t + ctxt <- getContext + ist <- get + imp <- impShow + let ty' = normaliseC ctxt [] ty + iputStrLn (showImp imp (delab ist tm) ++ " : " ++ + showImp imp (delab ist ty)) +process fn Universes = do i <- get + let cs = idris_constraints i +-- iputStrLn $ showSep "\n" (map show cs) + liftIO $ print (map fst cs) + let n = length cs + iputStrLn $ "(" ++ show n ++ " constraints)" + case ucheck cs of + Error e -> iputStrLn $ pshow i e + OK _ -> iputStrLn "Universes OK" +process fn (Defn n) = do i <- get + iputStrLn "Compiled patterns:\n" + liftIO $ print (lookupDef Nothing n (tt_ctxt i)) + case lookupCtxt Nothing n (idris_patdefs i) of + [] -> return () + [d] -> do iputStrLn "Original definiton:\n" + mapM_ (printCase i) d + where printCase i (lhs, rhs) = do liftIO $ putStr $ showImp True (delab i lhs) + liftIO $ putStr " = " + liftIO $ putStrLn $ showImp True (delab i rhs) +process fn (Info n) = do i <- get + let oi = lookupCtxt Nothing n (idris_optimisation i) + liftIO $ print oi +process fn (Spec t) = do (tm, ty) <- elabVal toplevel False t + ctxt <- getContext + ist <- get + let tm' = specialise ctxt (idris_statics ist) tm + iputStrLn (show (delab ist tm')) +process fn (Prove n) = prover (lit fn) n +process fn (HNF t) = do (tm, ty) <- elabVal toplevel False t + ctxt <- getContext + ist <- get + let tm' = simplify ctxt [] tm + iputStrLn (show (delab ist tm')) +process fn TTShell = do ist <- get + let shst = initState (tt_ctxt ist) + shst' <- lift $ runShell shst + return () +process fn Execute = do (m, _) <- elabVal toplevel False + (PApp fc + (PRef fc (UN "run__IO")) + [pexp $ PRef fc (NS (UN "main") ["main"])]) +-- (PRef (FC "main" 0) (NS (UN "main") ["main"])) + (tmpn, tmph) <- liftIO tempfile + liftIO $ hClose tmph + compile tmpn m + liftIO $ system tmpn + return () + where fc = FC "main" 0 +process fn (Compile f) = do (m, _) <- elabVal toplevel False + (PApp fc + (PRef fc (UN "run__IO")) + [pexp $ PRef fc (NS (UN "main") ["main"])]) + compile f m + where fc = FC "main" 0 +process fn (LogLvl i) = setLogLevel i +process fn Metavars + = do ist <- get + let mvs = idris_metavars ist \\ primDefs + case mvs of + [] -> iputStrLn "No global metavariables to solve" + _ -> iputStrLn $ "Global metavariables:\n\t" ++ show mvs +process fn NOP = return () + +displayHelp = let vstr = showVersion version in + "\nIdris version " ++ vstr ++ "\n" ++ + "--------------" ++ map (\x -> '-') vstr ++ "\n\n" ++ + concatMap cmdInfo help + where cmdInfo (cmds, args, text) = " " ++ col 16 12 (showSep " " cmds) args text + col c1 c2 l m r = + l ++ take (c1 - length l) (repeat ' ') ++ + m ++ take (c2 - length m) (repeat ' ') ++ r ++ "\n" + +help = + [ (["Command"], "Arguments", "Purpose"), + ([""], "", ""), + ([""], "", "Evaluate an expression"), + ([":t"], "", "Check the type of an expression"), + ([":r",":reload"], "", "Reload current file"), + ([":e",":edit"], "", "Edit current file using $EDITOR or $VISUAL"), + ([":m",":metavars"], "", "Show remaining proof obligations (metavariables)"), + ([":p",":prove"], "", "Prove a metavariable"), + ([":a",":addproof"], "", "Add last proof to source file"), + ([":c",":compile"], "", "Compile to an executable "), + ([":exec",":execute"], "", "Compile to an executable and run"), + ([":?",":h",":help"], "", "Display this help text"), + ([":q",":quit"], "", "Exit the Idris system") + ] + diff --git a/src/Idris/REPLParser.hs b/src/Idris/REPLParser.hs new file mode 100644 --- /dev/null +++ b/src/Idris/REPLParser.hs @@ -0,0 +1,43 @@ +module Idris.REPLParser(parseCmd) where + +import Idris.Parser +import Idris.AbsSyntax +import Core.TT + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as PTok + +import Debug.Trace +import Data.List + +parseCmd i = runParser pCmd i "(input)" + +cmd :: [String] -> IParser () +cmd xs = do lchar ':'; docmd (sortBy (\x y -> compare (length y) (length x)) xs) + where docmd [] = fail "No such command" + docmd (x:xs) = try (discard (symbol x)) <|> docmd xs + +pCmd :: IParser Command +pCmd = try (do cmd ["q", "quit"]; eof; return Quit) + <|> try (do cmd ["h", "?", "help"]; eof; return Help) + <|> try (do cmd ["r", "reload"]; eof; return Reload) + <|> try (do cmd ["e", "edit"]; eof; return Edit) + <|> try (do cmd ["exec", "execute"]; eof; return Execute) + <|> try (do cmd ["ttshell"]; eof; return TTShell) + <|> try (do cmd ["c", "compile"]; f <- identifier; eof; return (Compile f)) + <|> try (do cmd ["m", "metavars"]; eof; return Metavars) + <|> try (do cmd ["p", "prove"]; n <- pName; eof; return (Prove n)) + <|> try (do cmd ["a", "addproof"]; eof; return AddProof) + <|> try (do cmd ["log"]; i <- natural; eof; return (LogLvl (fromIntegral i))) + <|> try (do cmd ["spec"]; t <- pFullExpr defaultSyntax; return (Spec t)) + <|> try (do cmd ["hnf"]; t <- pFullExpr defaultSyntax; return (HNF t)) + <|> try (do cmd ["d", "def"]; n <- pName; eof; return (Defn n)) + <|> try (do cmd ["t", "type"]; do t <- pFullExpr defaultSyntax; return (Check t)) + <|> try (do cmd ["u", "universes"]; eof; return Universes) + <|> try (do cmd ["i", "info"]; n <- pfName; eof; return (Info n)) + <|> try (do cmd ["x"]; t <- pFullExpr defaultSyntax; return (ExecVal t)) + <|> do t <- pFullExpr defaultSyntax; return (Eval t) + <|> do eof; return NOP + diff --git a/src/Idris/Transforms.hs b/src/Idris/Transforms.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Transforms.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE PatternGuards #-} + +module Idris.Transforms where + +import Idris.AbsSyntax +import Core.CaseTree +import Core.TT + +class Transform a where + transform :: (a -> a) -> a -> a + +instance Transform (TT Name) where + transform t x = t (trans' x) where + trans' (Bind n b sc) = Bind n (fmap (transform t) b) (transform t sc) + trans' (App f a) = App (transform t f) (transform t a) + trans' x = x + +type TTOpt = TT Name -> TT Name + +optimisations :: [TTOpt] +optimisations = [zero, suc] + +instance Transform SC where + transform t x = t (trans' x) where + trans' (Case n alts) = Case n (map transAlt alts) + trans' t = t + + transAlt (ConCase n i as sc) = ConCase n i as (trans' sc) + transAlt (ConstCase c sc) = ConstCase c (trans' sc) + transAlt (DefaultCase sc) = DefaultCase (trans' sc) + +type CaseOpt = SC -> SC + +zero :: TTOpt +zero (P _ n _) | n == NS (UN "O") ["nat","prelude"] + = Constant (BI 0) +zero x = x + +suc :: TTOpt +suc (App (P _ s _) a) | s == NS (UN "S") ["nat","prelude"] + = mkApp (P Ref (UN "prim__addBigInt") Erased) [Constant (BI 1), a] +suc x = x + + diff --git a/src/Idris/Unlit.hs b/src/Idris/Unlit.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Unlit.hs @@ -0,0 +1,27 @@ +module Idris.Unlit(unlit) where + +import Core.TT +import Data.Char + +unlit :: FilePath -> String -> TC String +unlit f s = do let s' = map ulLine (lines s) + check f 1 s' + return $ unlines (map snd s') + +data LineType = Prog | Blank | Comm + +ulLine ('>':' ':xs) = (Prog, xs) +ulLine ('>':xs) = (Prog, xs) +ulLine xs | all isSpace xs = (Blank, "") + | otherwise = (Comm, '-':'-':xs) + +check f l (a:b:cs) = do chkAdj f l (fst a) (fst b) + check f (l+1) (b:cs) +check f l [x] = return () +check f l [] = return () + +chkAdj f l Prog Comm = tfail $ At (FC f l) ProgramLineComment +chkAdj f l Comm Prog = tfail $ At (FC f l) ProgramLineComment +chkAdj f l _ _ = return () + + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,128 @@ +module Main where + +import System.Console.Haskeline +import System.IO +import System.Environment +import System.Exit + +import Data.Maybe +import Data.Version +import Control.Monad.State + +import Core.CoreParser +import Core.ShellParser +import Core.TT +import Core.Typecheck +import Core.ProofShell +import Core.Evaluate +import Core.Constraints + +import Idris.AbsSyntax +import Idris.Parser +import Idris.REPL +import Idris.ElabDecls +import Idris.Primitives +import Idris.Imports +import Idris.Error +import Paths_idris + +-- Main program reads command line options, parses the main program, and gets +-- on with the REPL. + +data Opt = Filename String + | Ver + | Usage + | NoPrelude + | NoREPL + | OLogging Int + | Output String + | TypeCase + | TypeInType + | NoCoverage + | Verbose + deriving Eq + +main = do xs <- getArgs + opts <- parseArgs xs + runInputT defaultSettings $ execStateT (runIdris opts) idrisInit + +runIdris :: [Opt] -> Idris () +runIdris opts = + do let inputs = opt getFile opts + let runrepl = not (NoREPL `elem` opts) + let output = opt getOutput opts + when (Ver `elem` opts) $ liftIO showver + when (Usage `elem` opts) $ liftIO usage + setREPL runrepl + setVerbose runrepl + when (Verbose `elem` opts) $ setVerbose True + mapM_ makeOption opts + elabPrims + when (not (NoPrelude `elem` opts)) $ do x <- loadModule "prelude" + return () + when runrepl $ iputStrLn banner + ist <- get + mods <- mapM loadModule inputs + ok <- noErrors + when ok $ case output of + [] -> return () + (o:_) -> process "" (Compile o) + when runrepl $ repl ist inputs + ok <- noErrors + when (not ok) $ liftIO (exitWith (ExitFailure 1)) + where + makeOption (OLogging i) = setLogLevel i + makeOption TypeCase = setTypeCase True + makeOption TypeInType = setTypeInType True + makeOption NoCoverage = setCoverage False + makeOption _ = return () + +getFile :: Opt -> Maybe String +getFile (Filename str) = Just str +getFile _ = Nothing + +getOutput :: Opt -> Maybe String +getOutput (Output str) = Just str +getOutput _ = Nothing + +opt :: (Opt -> Maybe a) -> [Opt] -> [a] +opt = mapMaybe + +usage = do putStrLn usagemsg + exitWith ExitSuccess + +showver = do putStrLn $ "Idris version " ++ ver + exitWith ExitSuccess + +parseArgs :: [String] -> IO [Opt] +parseArgs [] = return [] +parseArgs ("--log":lvl:ns) = liftM (OLogging (read lvl) : ) (parseArgs ns) +parseArgs ("--noprelude":ns) = liftM (NoPrelude : ) (parseArgs ns) +parseArgs ("--check":ns) = liftM (NoREPL : ) (parseArgs ns) +parseArgs ("-o":n:ns) = liftM (\x -> NoREPL : Output n : x) (parseArgs ns) +parseArgs ("--typecase":ns) = liftM (TypeCase : ) (parseArgs ns) +parseArgs ("--typeintype":ns) = liftM (TypeInType : ) (parseArgs ns) +parseArgs ("--nocoverage":ns) = liftM (NoCoverage : ) (parseArgs ns) +parseArgs ("--help":ns) = liftM (Usage : ) (parseArgs ns) +parseArgs ("--version":ns) = liftM (Ver : ) (parseArgs ns) +parseArgs ("--verbose":ns) = liftM (Verbose : ) (parseArgs ns) +parseArgs (n:ns) = liftM (Filename n : ) (parseArgs ns) + +ver = showVersion version + +banner = " ____ __ _ \n" ++ + " / _/___/ /____(_)____ \n" ++ + " / // __ / ___/ / ___/ Version " ++ ver ++ "\n" ++ + " _/ // /_/ / / / (__ ) http://www.idris-lang.org/ \n" ++ + " /___/\\__,_/_/ /_/____/ Type :? for help \n" + +usagemsg = "Idris version " ++ ver ++ "\n" ++ + "--------------" ++ map (\x -> '-') ver ++ "\n" ++ + "Usage: idris [input file] [options]\n" ++ + "Options:\n" ++ + "\t--check Type check only\n" ++ + "\t-o [file] Generate executable\n" ++ + "\t--noprelude Don't import the prelude\n" ++ + "\t--typeintype Disable universe checking\n" ++ + "\t--log [level] Set debugging log level\n" + diff --git a/tutorial/examples/binary.idr b/tutorial/examples/binary.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/binary.idr @@ -0,0 +1,62 @@ +module main + +data Binary : Nat -> Set where + bEnd : Binary O + bO : Binary n -> Binary (n + n) + bI : Binary n -> Binary (S (n + n)) + +instance Show (Binary n) where + show (bO x) = show x ++ "0" + show (bI x) = show x ++ "1" + show bEnd = "" + +data Parity : Nat -> Set where + even : Parity (n + n) + odd : Parity (S (n + n)) + +parity : (n:Nat) -> Parity n +parity O = even {n=O} +parity (S O) = odd {n=O} +parity (S (S k)) with (parity k) + parity (S (S (j + j))) | even ?= even {n=S j} + parity (S (S (S (j + j)))) | odd ?= odd {n=S j} + +natToBin : (n:Nat) -> Binary n +natToBin O = bEnd +natToBin (S k) with (parity k) + natToBin (S (j + j)) | even = bI (natToBin j) + natToBin (S (S (j + j))) | odd ?= bO (natToBin (S j)) + +intToNat : Int -> Nat +intToNat 0 = O +intToNat x = if (x>0) then (S (intToNat (x-1))) else O + +main : IO () +main = do putStr "Enter a number: " + x <- getLine + print (natToBin (fromInteger (cast x))) + +---------- Proofs ---------- + +natToBin_lemma_1 = proof { + intro; + intro; + rewrite plusn_Sm j j; + trivial; +} + +parity_lemma_2 = proof { + intro; + intro; + rewrite plusn_Sm j j; + trivial; +} + +parity_lemma_1 = proof { + intro j; + intro; + rewrite plusn_Sm j j; + trivial; +} + + diff --git a/tutorial/examples/bmain.idr b/tutorial/examples/bmain.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/bmain.idr @@ -0,0 +1,8 @@ +module main + +import btree + +main : IO () +main = do let t = toTree [1,8,2,7,9,3] + print (toList t) + diff --git a/tutorial/examples/btree.idr b/tutorial/examples/btree.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/btree.idr @@ -0,0 +1,18 @@ +module btree + +data BTree a = Leaf + | Node (BTree a) a (BTree a) + +insert : Ord a => a -> BTree a -> BTree a +insert x Leaf = Node Leaf x Leaf +insert x (Node l v r) = if (x < v) then (Node (insert x l) v r) + else (Node l v (insert x r)) + +toList : BTree a -> List a +toList Leaf = [] +toList (Node l v r) = app (toList l) (v :: toList r) + +toTree : Ord a => List a -> BTree a +toTree [] = Leaf +toTree (x :: xs) = insert x (toTree xs) + diff --git a/tutorial/examples/classes.idr b/tutorial/examples/classes.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/classes.idr @@ -0,0 +1,10 @@ +m_add : Maybe Int -> Maybe Int -> Maybe Int +m_add x y = do x' <- x -- Extract value from x + y' <- y -- Extract value from y + return (x' + y') -- Add them + +m_add' : Maybe Int -> Maybe Int -> Maybe Int +m_add' x y = [ x' + y' | x' <- x, y' <- y ] + +sortAndShow : (Ord a, Show a) => List a -> String +sortAndShow xs = show (sort xs) diff --git a/tutorial/examples/foo.idr b/tutorial/examples/foo.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/foo.idr @@ -0,0 +1,10 @@ +module foo + +namespace x + test : Int -> Int + test x = x * 2 + +namespace y + test : String -> String + test x = x ++ x + diff --git a/tutorial/examples/hello.idr b/tutorial/examples/hello.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/hello.idr @@ -0,0 +1,5 @@ +module main + +main : IO () +main = putStrLn "Hello world" + diff --git a/tutorial/examples/interp.idr b/tutorial/examples/interp.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/interp.idr @@ -0,0 +1,65 @@ +module main + +data Ty = TyInt | TyBool| TyFun Ty Ty + +interpTy : Ty -> Set +interpTy TyInt = Int +interpTy TyBool = Bool +interpTy (TyFun s t) = interpTy s -> interpTy t + +using (G : Vect Ty n) + + data Env : Vect Ty n -> Set where + Nil : Env Nil + (::) : interpTy a -> Env G -> Env (a :: G) + + data HasType : (i : Fin n) -> Vect Ty n -> Ty -> Set where + stop : HasType fO (t :: G) t + pop : HasType k G t -> HasType (fS k) (u :: G) t + + lookup : HasType i G t -> Env G -> interpTy t + lookup stop (x :: xs) = x + lookup (pop k) (x :: xs) = lookup k xs + + data Expr : Vect Ty n -> Ty -> Set where + Var : HasType i G t -> Expr G t + Val : (x : Int) -> Expr G TyInt + Lam : Expr (a :: G) t -> Expr G (TyFun a t) + App : Expr G (TyFun a t) -> Expr G a -> Expr G t + Op : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> + Expr G c + If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a + + interp : Env G -> {static} Expr G t -> interpTy t + interp env (Var i) = lookup i env + interp env (Val x) = x + interp env (Lam sc) = \x => interp (x :: env) sc + interp env (App f s) = interp env f (interp env s) + interp env (Op op x y) = op (interp env x) (interp env y) + interp env (If x t e) = if interp env x then interp env t + else interp env e + + eId : Expr G (TyFun TyInt TyInt) + eId = Lam (Var stop) + + eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt)) + eAdd = Lam (Lam (Op (+) (Var stop) (Var (pop stop)))) + + eDouble : Expr G (TyFun TyInt TyInt) + eDouble = Lam (App (App eAdd (Var stop)) (Var stop)) + + app : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t + app = \f, a => App f a + + fact : Expr G (TyFun TyInt TyInt) + fact = Lam (If (Op (==) (Var stop) (Val 0)) + (Val 1) (Op (*) (app fact (Op (-) (Var stop) (Val 1))) (Var stop))) + +testFac : Int +testFac = interp [] fact 4 + +main : IO () +main = do putStr "Enter a number: " + x <- getLine + print (interp [] fact (cast x)) + diff --git a/tutorial/examples/letbind.idr b/tutorial/examples/letbind.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/letbind.idr @@ -0,0 +1,16 @@ +module letbind + +mirror : List a -> List a +mirror xs = let xs' = rev xs in + app xs xs' + +data Person = MkPerson String Int + +showPerson : Person -> String +showPerson p = let MkPerson name age = p in + name ++ " is " ++ show age ++ " years old" + +splitAt : Char -> String -> (String, String) +splitAt c x = case break (== c) x of + (x, y) => (x, strTail y) + diff --git a/tutorial/examples/prims.idr b/tutorial/examples/prims.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/prims.idr @@ -0,0 +1,14 @@ +module prims + +x : Int +x = 42 + +foo : String +foo = "Sausage machine" + +bar : Char +bar = 'Z' + +quux : Bool +quux = False + diff --git a/tutorial/examples/theorems.idr b/tutorial/examples/theorems.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/theorems.idr @@ -0,0 +1,38 @@ + +fiveIsFive : 5 = 5 +fiveIsFive = refl + +twoPlusTwo : 2 + 2 = 4 +twoPlusTwo = refl + +plusReduces : (n:Nat) -> plus O n = n +plusReduces n = refl + +plusReducesO : (n:Nat) -> n = plus n O +plusReducesO O = refl +plusReducesO (S k) = eqRespS (plusReducesO k) + +plusReducesS : (n:Nat) -> (m:Nat) -> S (plus n m) = plus n (S m) +plusReducesS O m = refl +plusReducesS (S k) m = eqRespS (plusReducesS k m) + +plusReducesO' : (n:Nat) -> n = plus n O +plusReducesO' O = ?plusredO_O +plusReducesO' (S k) = let ih = plusReducesO' k in + ?plusredO_S + + +---------- Proofs ---------- + +plusredO_S = proof { + intro; + intro; + rewrite ih; + trivial; +} + +plusredO_O = proof { + compute; + trivial; +} + diff --git a/tutorial/examples/universe.idr b/tutorial/examples/universe.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/universe.idr @@ -0,0 +1,7 @@ +myid : (a : Set) -> a -> a +myid _ x = x + +idid : (a : Set) -> a -> a +idid = myid _ myid + + diff --git a/tutorial/examples/usefultypes.idr b/tutorial/examples/usefultypes.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/usefultypes.idr @@ -0,0 +1,20 @@ + +intVec : Vect Int 5 +intVec = [1, 2, 3, 4, 5] + +double : Int -> Int +double x = x * 2 + +vec : (n ** Vect Int n) +vec = (_ ** [3, 4]) + +list_lookup : Nat -> List a -> Maybe a +list_lookup _ Nil = Nothing +list_lookup O (x :: xs) = Just x +list_lookup (S k) (x :: xs) = list_lookup k xs + +lookup_default : Nat -> List a -> a -> a +lookup_default i xs def = case list_lookup i xs of + Nothing => def + Just x => x + diff --git a/tutorial/examples/vbroken.idr b/tutorial/examples/vbroken.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/vbroken.idr @@ -0,0 +1,5 @@ +vapp : Vect a n -> Vect a m -> Vect a (n + m) +vapp Nil ys = ys +vapp (x :: xs) ys = x :: vapp xs xs -- BROKEN + + diff --git a/tutorial/examples/views.idr b/tutorial/examples/views.idr new file mode 100644 --- /dev/null +++ b/tutorial/examples/views.idr @@ -0,0 +1,37 @@ +module views + +data Parity : Nat -> Set where + even : Parity (n + n) + odd : Parity (S (n + n)) + +parity : (n:Nat) -> Parity n +parity O = even {n=O} +parity (S O) = odd {n=O} +parity (S (S k)) with (parity k) + parity (S (S (j + j))) | even ?= even {n=S j} + parity (S (S (S (j + j)))) | odd ?= odd {n=S j} + +natToBin : Nat -> List Bool +natToBin O = Nil +natToBin k with (parity k) + natToBin (j + j) | even = False :: natToBin j + natToBin (S (j + j)) | odd = True :: natToBin j + + +---------- Proofs ---------- + +views.parity_lemma_2 = proof { + intro; + intro; + rewrite plusn_Sm j j; + trivial; +} + +views.parity_lemma_1 = proof { + intro; + intro; + rewrite plusn_Sm j j; + trivial; +} + +