Annotations 0.2 → 0.2.1

raw patch · 15 files changed

+652/−14 lines, 15 filesdep +Annotationsdep ~basedep ~mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: Annotations

Dependency ranges changed: base, mtl

API changes (from Hackage documentation)

Files

• Annotations.cabal +27/−5
• Annotations/F/Positional.hs +1/−1
• Annotations/MultiRec/Annotated.hs +1/−1
• Annotations/MultiRec/Positional.hs +1/−1
• Annotations/MultiRec/Yield.hs +2/−2
• Annotations/MultiRec/ZipperFix.hs +3/−3
• LICENSE +1/−1
• tests/F/Expr.hs +113/−0
• tests/F/ExprLexer.hs +71/−0
• tests/F/ExprParser.hs +40/−0
• tests/MultiRec/Expr.hs +123/−0
• tests/MultiRec/ExprExpl.hs +105/−0
• tests/MultiRec/ExprLexer.hs +72/−0
• tests/MultiRec/ExprParser.hs +82/−0
• tests/Tests.hs +10/−0

@@ -1,5 +1,5 @@ Name:           Annotations-Version:        0.2+Version:        0.2.1 Synopsis:       Constructing, analyzing and destructing annotated trees Description:   @Annotations@ provides utility functions to make working with annotated trees easier. There are two implementations: one for working with open datatypes that explicitly make their child positions accessible through a type argument, and one for working with MultiRec datatypes.@@ -10,17 +10,23 @@  Author:         Martijn van Steenbergen Maintainer:     martijn@van.steenbergen.nl-Copyright:      Copyright (c) 2008-2009 Martijn van Steenbergen+Copyright:      Copyright (c) 2008-2015 Martijn van Steenbergen -Cabal-Version:  >= 1.2+Cabal-Version:  >= 1.8 License:        BSD3 License-file:   LICENSE Category:       Generics Build-type:     Simple +Source-Repository head+  Type:         git+  Location:     https://github.com/MedeaMelana/Annotations+ Library-  Build-Depends:    base >= 4.1 && < 4.6, mtl >= 1.1 && < 2.1,-                    parsec >= 3.0 && < 3.2, multirec >= 0.4 && < 0.8+  Build-Depends:    base < 5,+                    mtl >= 1.1 && < 2.3,+                    parsec >= 3.0 && < 3.2,+                    multirec >= 0.4 && < 0.8   Exposed-Modules:  Annotations.Bounds,                     Annotations.BoundsParser,                     Annotations.Except,@@ -40,3 +46,19 @@                     Annotations.MultiRec.ZipperFix,                     Annotations.MultiRec.Positional +Test-Suite tests+  Type:             exitcode-stdio-1.0+  Hs-Source-Dirs:   tests+  Main-Is:          Tests.hs+  Other-Modules:    F.Expr,+                    F.ExprLexer,+                    F.ExprParser,+                    MultiRec.Expr,+                    MultiRec.ExprExpl,+                    MultiRec.ExprLexer,+                    MultiRec.ExprParser+  Build-Depends:    Annotations,+                    base >= 3.0 && < 5,+                    mtl >= 1.1 && < 2.3,+                    parsec >= 3.0 && < 3.2,+                    multirec >= 0.4 && < 0.8

@@ -11,7 +11,7 @@  import Data.Foldable (Foldable, toList) import Data.Ord-import Data.List+import Data.List (sortBy) import Data.Maybe import Control.Applicative 

@@ -4,6 +4,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}  module Annotations.MultiRec.Annotated (     AnnFix, AnnFix1, mkAnnFix, AnyAnnFix,@@ -19,7 +20,6 @@ import Control.Monad.Writer (Writer, execWriter, tell)  import Generics.MultiRec hiding (show)-import Generics.MultiRec.HFix import Annotations.MultiRec.Zipper import Annotations.MultiRec.ZipperFix 

@@ -13,7 +13,7 @@ import Generics.MultiRec.HFunctor  import Data.Maybe-import Data.List+import Data.List (sortBy) import Data.Ord import Control.Applicative 

@@ -11,11 +11,11 @@   , runYield, runYieldG, runYieldT, runYieldTG   ) where +import Control.Applicative (Applicative) import Control.Monad.State.Strict import Control.Monad.Identity  import Generics.MultiRec hiding (show)-import Generics.MultiRec.HFix  import Annotations.MultiRec.Annotated import Annotations.MultiRec.Any@@ -34,7 +34,7 @@  -- | The Yield transformer. Allows yielding generic values in family @fam@ with annotations of type @x@. newtype YieldT x fam m a = YieldT (StateT [AnyAnnFix x fam] m a)-  deriving (Functor, Monad)+  deriving (Functor, Applicative, Monad)  runYieldTG :: Monad m => YieldT x fam m a -> m (a, Maybe (AnyAnnFix x fam)) runYieldTG (YieldT y) = do

@@ -44,11 +44,11 @@  down  (Loc p (HIn x) s      ) = first (\p' z c  -> Loc p' z (Push p c  s)) x down' (Loc p (HIn x) s      ) = last  (\p' z c  -> Loc p' z (Push p c  s)) x-up    (Loc p x Empty        ) = Nothing+up    (Loc _ _ Empty        ) = Nothing up    (Loc p x (Push p' c s)) = return (Loc p' (HIn $ fill p c x) s)-right (Loc p x Empty        ) = Nothing+right (Loc _ _ Empty        ) = Nothing right (Loc p x (Push p' c s)) = next (\p z c' -> Loc p z (Push p' c' s)) p c x-left  (Loc p x Empty        ) = Nothing+left  (Loc _ _ Empty        ) = Nothing left  (Loc p x (Push p' c s)) = prev (\p z c' -> Loc p z (Push p' c' s)) p c x  -- ** Derived navigation.

@@ -1,4 +1,4 @@-Copyright (c) 2008-2009, Martijn van Steenbergen+Copyright (c) 2008-2015, Martijn van Steenbergen All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -0,0 +1,113 @@+module F.Expr where++import Annotations.Bounds+import Annotations.F.Annotated+import Annotations.F.Fixpoints++import Control.Applicative (Applicative(..), (<$>))+import Data.Foldable (Foldable(..))+import Data.Traversable+++-- type  PositionalExpr = (Bounds, PositionalExpr')+-- data  PositionalExpr'+--   =  Add  PositionalExpr  PositionalExpr+--   |  Sub  PositionalExpr  PositionalExpr+--   |  Mul  PositionalExpr  PositionalExpr+--   |  Div  PositionalExpr  PositionalExpr+--   |  Num  Int++data ExprF rT+  =  Add  rT  rT+  |  Sub  rT  rT+  |  Mul  rT  rT+  |  Div  rT  rT+  |  Num  Int+  deriving (Eq, Show)++instance Functor ExprF where+  fmap = fmapDefault++instance Foldable ExprF where+  foldMap = foldMapDefault++instance Traversable ExprF where+  traverse f expr = case expr of+    Add x y -> Add <$> f x <*> f y+    Sub x y -> Sub <$> f x <*> f y+    Mul x y -> Mul <$> f x <*> f y+    Div x y -> Div <$> f x <*> f y+    Num n   -> pure (Num n)++-- newtype Expr = Expr (ExprF Expr)+-- data PositionalExpr = PositionalExpr Bounds (ExprF PositionalExpr)++newtype Expr    = Expr  { runExpr  :: Fix ExprF    }+  deriving (Eq, Show)++instance Num Expr where+  fromInteger = Expr . In . Num . fromIntegral+  Expr x + Expr y = Expr $ In $ Add x y+  Expr x - Expr y = Expr $ In $ Sub x y+  Expr x * Expr y = Expr $ In $ Mul x y+  negate = (0 -)+  abs = error "abs"+  signum = error "signum"++instance Fractional Expr where+  Expr x / Expr y = Expr $ In $ Div x y+  fromRational = error "fromRational"++type PositionalExpr = Fix (Ann Bounds ExprF)++cataExpr :: (ExprF a -> a) -> Fix ExprF -> a+cataExpr f (In expr) = f (fmap (cataExpr f) expr)++data ExprAlg a = ExprAlg+  { cataNum :: Int -> a+  , cataAdd :: a -> a -> a+  , cataSub :: a -> a -> a+  , cataMul :: a -> a -> a+  , cataDiv :: a -> a -> a+  }++cataExpr0 :: ExprAlg a -> Fix ExprF -> a+cataExpr0 alg = f where+  f (In expr) = case expr of+    Num n    -> cataNum  alg n+    Add x y  -> cataAdd  alg (f x) (f y)+    Sub x y  -> cataSub  alg (f x) (f y)+    Mul x y  -> cataMul  alg (f x) (f y)+    Div x y  -> cataDiv  alg (f x) (f y)++exprEval :: Algebra ExprF Int+exprEval expr = case expr of+  Num  n    -> n+  Add  x y  -> x + y+  Sub  x y  -> x - y+  Mul  x y  -> x * y+  Div  x y  -> x `div` y++exprEval' :: Algebra (Ann Bounds ExprF)+  (Either (Bounds, String) Int)+exprEval' (Ann z expr) = case expr of+    Num n     -> Right n+    Add  x y  -> (+)  <$> x <*> y+    Sub  x y  -> (-)  <$> x <*> y+    Mul  x y  -> (*)  <$> x <*> y+    Div  x y  -> do+      x' <- x+      y' <- y+      if y' == 0+        then Left   (z, "division by zero")+        else Right  (x' `div` y')++exprEvalE :: ErrorAlgebra ExprF String Int+exprEvalE expr = case expr of+  Num  n         -> Right n+  Add  x y       -> Right (x +  y)+  Sub  x y       -> Right (x -  y)+  Mul  x y       -> Right (x *  y)+  Div  x y+    | y == 0     -> Left "division by zero"+    | otherwise  -> Right (x `div` y)

@@ -0,0 +1,71 @@+-- | Provides tokens and a lexer for a simple arithmetic expression language.+module F.ExprLexer (+    -- * The token datatype+    ExprToken(..), isSpace, isNum,+    +    -- * Parsing tokens+    CharParser, pTokens+  ) where++import Annotations.BoundsParser++import Data.Maybe (fromJust)+import Control.Applicative+import qualified Text.Parsec as P+++-- | Tokens in the language.+data ExprToken+  =  TNum    Int+  |  TPlus+  |  TMinus+  |  TStar+  |  TSlash+  |  TOpen+  |  TClose+  |  TSpace  String+  deriving (Eq, Show)++instance Symbol ExprToken where+  unparse t = case t of+    TNum n -> show n+    TSpace s -> s+    _ -> fromJust (lookup t statics)++-- | True iff it is a 'TNum'.+isNum :: ExprToken -> Bool+isNum (TNum _)  = True+isNum _         = False++-- | True iff it is a 'TSpace'.+isSpace :: ExprToken -> Bool+isSpace (TSpace _)  = True+isSpace _           = False+++-- | A parser without user state that works on strings.+type CharParser = P.Parsec String ()++-- | A parses that recognises a stream of 'ExprToken's.+pTokens :: CharParser [ExprToken]+pTokens = many (P.choice [pStaticToken, pInt, pSpace])++statics :: [(ExprToken, String)]+statics =+  [ (TPlus, "+")+  , (TMinus, "-")+  , (TStar, "*")+  , (TSlash, "/")+  , (TOpen, "(")+  , (TClose, ")")+  ]++pStaticToken :: CharParser ExprToken+pStaticToken = P.choice $ map (\(tok, syn) -> tok <$ P.string syn) statics++pSpace :: CharParser ExprToken+pSpace = TSpace <$> some (P.oneOf " \n\r\t\f")++pInt :: CharParser ExprToken+pInt = TNum 0 <$ P.char '0'+   <|> (\n -> TNum . read . (n:)) <$> P.oneOf ['1'..'9'] <*> many (P.oneOf ['0'..'9'])

@@ -0,0 +1,40 @@+{-# LANGUAGE Rank2Types #-}++module F.ExprParser (+    ExprParser, pExpr, parseExpr+  ) where++import F.ExprLexer+import F.Expr++import Annotations.Bounds+import Annotations.BoundsParser+import Annotations.F.Annotated+import Annotations.F.ParserCombinators++import Control.Applicative+import qualified Text.Parsec as P+++-- | A bounds parser that works on 'ExprToken's.+type ExprParser a = forall m. Monad m => P ExprToken m a++-- | Recognises expressions. The expressions are annotated with position information.+pExpr :: ExprParser (AnnFix Bounds ExprF)+pExpr = chainl pTerm (Add <$ pToken TPlus <|> Sub <$ pToken TMinus)++pTerm :: ExprParser (AnnFix Bounds ExprF)+pTerm = chainl pFactor (Mul <$ pToken TStar <|> Div <$ pToken TSlash)++pFactor :: ExprParser (AnnFix Bounds ExprF)+pFactor = pNum <|> pToken TOpen *> pExpr <* pToken TClose++pNum :: ExprParser (AnnFix Bounds ExprF)+pNum = unit $ (\(TNum n) -> Num n) <$> satisfy isNum++-- | Runs 'pTokens' on the input and and 'pExpr' on the resulting tokens.+parseExpr :: String -> Either P.ParseError (AnnFix Bounds ExprF)+parseExpr input = do+  toks <- P.runParser (collapse isSpace <$> pTokens) () "" input+  let startMargin = (leftMargin . snd . head) toks+  P.runParser (pExpr <* P.eof) startMargin "" toks

@@ -0,0 +1,123 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Rank2Types #-}++module MultiRec.Expr where++import Annotations.MultiRec.ShowFam+import Annotations.MultiRec.ErrorAlg++import Generics.MultiRec.Base+++data Expr+  = EAdd     Expr  Expr+  | EMul     Expr  Expr+  | ETup     Expr  Expr+  | EIntLit  Int+  | ETyped   Expr  Type+  deriving (Eq, Show)++data Type+  = TyInt+  | TyTup  Type Type+  deriving (Eq, Show)+++type PF_Expr =+       I  Expr  :*:  I  Expr  :*:  U+  :+:  I  Expr  :*:  I  Expr  :*:  U+  :+:  I  Expr  :*:  I  Expr  :*:  U+  :+:  K  Int   :*:  U+  :+:  I  Expr  :*:  I  Type  :*:  U++type PF_Type =+       U+  :+:  I  Type  :*:  I  Type  :*:  U++type instance PF Tuples = PF_Expr :>: Expr :+: PF_Type :>: Type++data Tuples :: * -> * where+  Expr  :: Tuples Expr+  Type  :: Tuples Type++instance EqS Tuples where+  eqS Expr Expr = Just Refl+  eqS Type Type = Just Refl+  eqS _    _    = Nothing++instance El Tuples Expr where+  proof = Expr++instance El Tuples Type where+  proof = Type++instance ShowFam Tuples where+  showFam Expr  = show+  showFam Type  = show++instance Fam Tuples where++  from Expr ex  = L . Tag $ case ex of+    EAdd x y     -> L              $ I (I0 x)  :*: I (I0 y)  :*: U+    EMul x y     -> R . L          $ I (I0 x)  :*: I (I0 y)  :*: U+    ETup x y     -> R . R . L      $ I (I0 x)  :*: I (I0 y)  :*: U+    EIntLit n    -> R . R . R . L  $ K n       :*: U+    ETyped e t   -> R . R . R . R  $ I (I0 e)  :*: I (I0 t)  :*: U+  from Type ty  = R . Tag $ case ty of+      TyInt      -> L              $ U+      TyTup x y  -> R              $ I (I0 x)  :*: I (I0 y)  :*: U++  to Expr (L (Tag ex))  = case ex of+    L           (I (I0 x) :*: I (I0 y) :*: U)     -> EAdd x y+    R (L        (I (I0 x) :*: I (I0 y) :*: U))    -> EMul x y+    R (R (L     (I (I0 x) :*: I (I0 y) :*: U)))   -> ETup x y+    R (R (R (L  (K n                   :*: U))))  -> EIntLit n+    R (R (R (R  (I (I0 x) :*: I (I0 y) :*: U))))  -> ETyped x y+  to Type (R (Tag ty))  = case ty of+    L           U                                 -> TyInt+    R           (I (I0 x) :*: I (I0 y) :*: U)     -> TyTup x y++-- $(deriveConstructors [''Expr, ''Type])+-- $(deriveFamily ''AST [''Expr, ''Type] "PFAST")+-- type instance PF AST = PFAST++-- inferTypeExpr :: ErrorAlg (PF_Expr :>: Expr) String Type+-- inferTypeExpr = undefined & undefined & undefined & undefined & undefined+-- +-- inferTypeType :: ErrorAlg (PF_Type :>: Type) String Type+-- inferTypeType = undefined & undefined+-- +-- inferType :: ErrorAlg (PF_Tuples) String Type+-- inferType = inferTypeExpr & inferTypeType++-- inferType :: ErrorAlg (PF Tuples) String Type++type ExprErrorAlg e a+   =   (a     -> a     ->  Either e a)+  :&:  (a     -> a     ->  Either e a)+  :&:  (a     -> a     ->  Either e a)+  :&:  (Int            ->  Either e a)+  :&:  (a     -> a     ->  Either e a)++type TypeErrorAlg e a+   =                       Either e a+  :&:  (a     -> a     ->  Either e a)++-- inferType :: ExprErrorAlg String Type :&: TypeErrorAlg String Type+inferType :: ErrorAlg (PF Tuples) String Type+inferType = ( equal "+" & equal "*" & tup & const (Right TyInt) & equal "::" )+          & ( Right TyInt & tup )+  where+    equal op ty1 ty2+      | ty1 == ty2 = Right ty1+      | otherwise  = Left ("lhs and rhs of " ++ op ++ " must have equal types")+    tup ty1 ty2 = Right (TyTup ty1 ty2)++type (:&:) = (,)+infixr :&:

@@ -0,0 +1,105 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}++module MultiRec.ExprExpl where++import Generics.MultiRec+++data Expr+  = EAdd     Expr  Expr+  | EMul     Expr  Expr+  | ETup     Expr  Expr+  | EIntLit  Int+  | ETyped   Expr  Type+  deriving (Eq, Show)++data Type+  = TyInt+  | TyTup  Type Type+  deriving (Eq, Show)++type PF_Expr =+       I  Expr  :*:  I  Expr  :*:  U+  :+:  I  Expr  :*:  I  Expr  :*:  U+  :+:  I  Expr  :*:  I  Expr  :*:  U+  :+:  K  Int   :*:  U+  :+:  I  Expr  :*:  I  Type  :*:  U++type PF_Type =+       U+  :+:  I  Type  :*:  I  Type  :*:  U++type PF_Tuples = PF_Expr :>: Expr :+: PF_Type :>: Type++data Tuples :: * -> * where+  Expr :: Tuples Expr+  Type :: Tuples Type++type instance PF Tuples = PF_Tuples++instance EqS Tuples where+  eqS Expr Expr = Just Refl+  eqS Type Type = Just Refl+  eqS _    _    = Nothing++instance El Tuples Expr where+  proof = Expr++instance El Tuples Type where+  proof = Type++instance Fam Tuples where++  from Expr ex = L . Tag $ case ex of+    EAdd x y     -> L              $ I (I0 x)  :*: I (I0 y)  :*: U+    EMul x y     -> R . L          $ I (I0 x)  :*: I (I0 y)  :*: U+    ETup x y     -> R . R . L      $ I (I0 x)  :*: I (I0 y)  :*: U+    EIntLit n    -> R . R . R . L  $ K n       :*: U+    ETyped e t   -> R . R . R . R  $ I (I0 e)  :*: I (I0 t)  :*: U+  from Type ty = R . Tag $ case ty of+      TyInt      -> L              $ U+      TyTup x y  -> R              $ I (I0 x)  :*: I (I0 y)  :*: U++  to Expr (L (Tag ex)) = case ex of+    L          (I (I0 x) :*: I (I0 y) :*: U)     -> EAdd x y+    R (L       (I (I0 x) :*: I (I0 y) :*: U))    -> EMul x y+    R (R (L    (I (I0 x) :*: I (I0 y) :*: U)))   -> ETup x y+    R (R (R (L (K n                   :*: U))))  -> EIntLit n+    R (R (R (R (I (I0 x) :*: I (I0 y) :*: U))))  -> ETyped x y+  to Type (R (Tag ty)) = case ty of+    L          U                                 -> TyInt+    R          (I (I0 x) :*: I (I0 y) :*: U)     -> TyTup x y+++type family ErrorAlg (f :: (* -> *) -> * -> *) e ix :: *++type instance ErrorAlg U              e a = Either e a+type instance ErrorAlg (K b   :*: f)  e a = b  -> ErrorAlg f e a+type instance ErrorAlg (I xi  :*: f)  e a = a  -> ErrorAlg f e a+type instance ErrorAlg (f :+: g)      e a = (ErrorAlg f e a, ErrorAlg g e a)+type instance ErrorAlg (f :>: xi)     e a = ErrorAlg f e a++class MkErrorAlg f where+  mkErrorAlg :: ErrorAlg f e a -> f (K0 a) ix -> Either e a++instance MkErrorAlg U where+  mkErrorAlg x U = x++instance MkErrorAlg f => MkErrorAlg (K a :*: f) where+  mkErrorAlg alg (K x :*: f) = mkErrorAlg (alg x) f++instance MkErrorAlg f => MkErrorAlg (I xi :*: f) where+  mkErrorAlg alg (I (K0 x) :*: f) = mkErrorAlg (alg x) f++instance MkErrorAlg f => MkErrorAlg (f :>: xi) where+  mkErrorAlg alg (Tag f) = mkErrorAlg alg f++instance (MkErrorAlg f, MkErrorAlg g) => MkErrorAlg (f :+: g) where+  mkErrorAlg (alg, _) (L x) = mkErrorAlg alg x+  mkErrorAlg (_, alg) (R y) = mkErrorAlg alg y

@@ -0,0 +1,72 @@+module MultiRec.ExprLexer (ExprToken(..), isSpace, isIntLit, pTokens) where++import Annotations.BoundsParser++import qualified Text.Parsec as P++import Data.Maybe (fromJust)+import Control.Applicative+++data ExprToken+  = TIntLit Int+  | TPlus+  | TStar+  | TLParen+  | TRParen+  | TDoubleColon+  | TInt+  | TComma+  | TSpace String+  deriving (Eq, Show)++instance Symbol ExprToken where+  unparse t = case t of+    TIntLit n -> show n+    TSpace s -> s+    -- TVar s -> s+    _ -> fromJust (lookup t statics)++-- | True iff it is a 'TIntLit'.+isIntLit :: ExprToken -> Bool+isIntLit (TIntLit _)  = True+isIntLit _            = False++-- -- | True iff it is a 'TVar'.+-- isVar :: ExprToken -> Bool+-- isVar (TVar _)  = True+-- isVar _         = False++-- | True iff it is a 'TSpace'.+isSpace :: ExprToken -> Bool+isSpace (TSpace _)  = True+isSpace _           = False++statics :: [(ExprToken, String)]+statics =+  [ (TPlus, "+")+  , (TStar, "*")+  , (TLParen, "(")+  , (TRParen, ")")+  , (TDoubleColon, "::")+  , (TInt, "Int")+  -- , (TArrow, "->")+  -- , (TBackslash, "\\")+  , (TComma, ",")+  ]++-- | A parser without user state that works on strings.+type CharParser = P.Parsec String ()++pTokens :: CharParser [ExprToken]+pTokens = many (P.choice [pStaticToken, pInt, pSpace]) <* P.eof++pStaticToken :: CharParser ExprToken+pStaticToken = P.choice $ map (\(tok, syn) -> tok <$ P.string syn) statics++pSpace :: CharParser ExprToken+pSpace = TSpace <$> some (P.oneOf " \n\r\t\f")++pInt :: CharParser ExprToken+pInt = TIntLit 0 <$ P.char '0'+   <|> (\n -> TIntLit . read . (n:)) <$> P.oneOf ['1'..'9'] <*> many (P.oneOf ['0'..'9'])

@@ -0,0 +1,82 @@+module MultiRec.ExprParser where++import Annotations.Bounds+import Annotations.BoundsParser+import MultiRec.ExprLexer+import MultiRec.Expr+import Annotations.MultiRec.ErrorAlg+import Annotations.MultiRec.ParserCombinators+import Annotations.Except+import Annotations.MultiRec.Annotated+import Annotations.MultiRec.Yield+import Annotations.MultiRec.Any++import qualified Text.Parsec as P++import Data.Maybe+import Control.Applicative+import Control.Monad.Identity++import Debug.Trace+++type ExprParser = YP ExprToken Tuples Identity++pExpr :: ExprParser Expr+pExpr = do+  left <- getPos+  ex <- pAdd+  P.option ex $ do+    void (pToken TDoubleColon)+    ty <- pType+    mkBounded Expr left (ETyped ex ty)++pAdd :: ExprParser Expr+pAdd = chainl Expr pMul (EAdd <$ pToken TPlus)++pMul :: ExprParser Expr+pMul = chainl Expr pFactor (EAdd <$ pToken TStar)++pFactor :: ExprParser Expr+pFactor = pIntLit <|> pTupleVal++pIntLit :: ExprParser Expr+pIntLit = unit Expr $ (\(TIntLit n) -> EIntLit n) <$> satisfy isIntLit++pTupleVal :: ExprParser Expr+pTupleVal = pTuple Expr pExpr ETup++pType :: ExprParser Type+pType = pTyInt <|> pTyTuple++pTuple :: Tuples ix -> ExprParser ix -> (ix -> ix -> ix) -> ExprParser ix+pTuple w pEl f = do+  left <- getPos+  void (pToken TLParen)+  lhs <- pEl+  ty <- P.option lhs $ do+    void (pToken TComma)+    rhs <- pEl+    mkBounded w left (f lhs rhs)+  void (pToken TRParen)+  return ty++pTyTuple :: ExprParser Type+pTyTuple = pTuple Type pType TyTup++pTyInt :: ExprParser Type+pTyInt = unit Type $ TyInt <$ pToken TInt++readExpr :: String -> AnnFix Bounds Tuples Expr+readExpr input = case P.runParser pTokens () "" input of+  Left msg -> error (show msg)+  Right toks ->+    let toks' = trace (show toks) $ collapse isSpace toks+        leftmost = leftMargin $ snd $ head toks'+        p = P.runParserT (pExpr <* P.eof) leftmost "" toks'+     in case runYieldG p of+       (Left msg, _) -> error (show msg)+       (Right _, Just expr) -> fromJust (matchAnyF Expr expr)++inferExprType :: String -> Except [(String, Bounds)] Type+inferExprType = errorCata (mkErrorAlg inferType) Expr . readExpr

@@ -0,0 +1,10 @@+module Main where++-- Force compilation of these modules by importing them+import F.ExprParser ()+import MultiRec.ExprParser ()+import MultiRec.ExprExpl ()+++main :: IO ()+main = return ()