diff --git a/Annotations.cabal b/Annotations.cabal --- a/Annotations.cabal +++ b/Annotations.cabal @@ -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 diff --git a/Annotations/F/Positional.hs b/Annotations/F/Positional.hs --- a/Annotations/F/Positional.hs +++ b/Annotations/F/Positional.hs @@ -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 diff --git a/Annotations/MultiRec/Annotated.hs b/Annotations/MultiRec/Annotated.hs --- a/Annotations/MultiRec/Annotated.hs +++ b/Annotations/MultiRec/Annotated.hs @@ -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 diff --git a/Annotations/MultiRec/Positional.hs b/Annotations/MultiRec/Positional.hs --- a/Annotations/MultiRec/Positional.hs +++ b/Annotations/MultiRec/Positional.hs @@ -13,7 +13,7 @@ import Generics.MultiRec.HFunctor import Data.Maybe -import Data.List +import Data.List (sortBy) import Data.Ord import Control.Applicative diff --git a/Annotations/MultiRec/Yield.hs b/Annotations/MultiRec/Yield.hs --- a/Annotations/MultiRec/Yield.hs +++ b/Annotations/MultiRec/Yield.hs @@ -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 diff --git a/Annotations/MultiRec/ZipperFix.hs b/Annotations/MultiRec/ZipperFix.hs --- a/Annotations/MultiRec/ZipperFix.hs +++ b/Annotations/MultiRec/ZipperFix.hs @@ -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. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/tests/F/Expr.hs b/tests/F/Expr.hs new file mode 100644 --- /dev/null +++ b/tests/F/Expr.hs @@ -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) diff --git a/tests/F/ExprLexer.hs b/tests/F/ExprLexer.hs new file mode 100644 --- /dev/null +++ b/tests/F/ExprLexer.hs @@ -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']) diff --git a/tests/F/ExprParser.hs b/tests/F/ExprParser.hs new file mode 100644 --- /dev/null +++ b/tests/F/ExprParser.hs @@ -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 diff --git a/tests/MultiRec/Expr.hs b/tests/MultiRec/Expr.hs new file mode 100644 --- /dev/null +++ b/tests/MultiRec/Expr.hs @@ -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 :&: diff --git a/tests/MultiRec/ExprExpl.hs b/tests/MultiRec/ExprExpl.hs new file mode 100644 --- /dev/null +++ b/tests/MultiRec/ExprExpl.hs @@ -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 diff --git a/tests/MultiRec/ExprLexer.hs b/tests/MultiRec/ExprLexer.hs new file mode 100644 --- /dev/null +++ b/tests/MultiRec/ExprLexer.hs @@ -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']) diff --git a/tests/MultiRec/ExprParser.hs b/tests/MultiRec/ExprParser.hs new file mode 100644 --- /dev/null +++ b/tests/MultiRec/ExprParser.hs @@ -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 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -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 ()