language-ats 1.2.0.11 → 1.2.0.14

raw patch · 7 files changed

+366/−40 lines, 7 filesdep +recursion-schemesdep −micro-recursion-schemesdep −microlens-thPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: recursion-schemes

Dependencies removed: micro-recursion-schemes, microlens-th

API changes (from Hackage documentation)

Files

• language-ats.cabal +4/−7
• src/Language/ATS.hs +1/−0
• src/Language/ATS/Lexer.x +3/−0
• src/Language/ATS/Parser.y +3/−0
• src/Language/ATS/PrettyPrint.hs +2/−0
• src/Language/ATS/Types.hs +351/−32
• test/Spec.hs +2/−1

@@ -1,6 +1,6 @@ cabal-version: 1.18 name: language-ats-version: 1.2.0.11+version: 1.2.0.14 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018 Vanessa McHale@@ -41,17 +41,14 @@     default-language: Haskell2010     other-extensions: OverloadedStrings DeriveGeneric DeriveAnyClass                       FlexibleContexts FlexibleInstances PatternSynonyms-                      StandaloneDeriving LambdaCase GeneralizedNewtypeDeriving-                      DeriveTraversable DerivingStrategies DuplicateRecordFields-                      DeriveFoldable DeriveDataTypeable DeriveFunctor TypeFamilies-                      TemplateHaskell CPP MagicHash+                      StandaloneDeriving GeneralizedNewtypeDeriving DerivingStrategies+                      DuplicateRecordFields DeriveFunctor TypeFamilies     ghc-options: -Wall     build-depends:         base >=4.9 && <5,         array -any,-        micro-recursion-schemes >=5.0.1,+        recursion-schemes >=5.0.1,         microlens -any,-        microlens-th -any,         deepseq -any,         ansi-wl-pprint >=0.6.8,         composition-prelude -any,

@@ -81,6 +81,7 @@ -- | Same as 'printErr', but print a yellow warning message instead. warnErr :: MonadIO m => FilePath -> ATSError -> m () warnErr fp = liftIO . hPutDoc stderr . ((dullyellow "Warning" <+> text (fp <> ":")) <+> ) . preErr+-- TODO: this should detect if being piped to terminal!  -- | Parse a string containing ATS source, disregarding comments. parseM :: String -> Either ATSError (ATS AlexPosn)

@@ -165,6 +165,7 @@     <0> dataview                 { tok (\p _ -> alex $ Keyword p KwDataview) }     <0> dataprop                 { tok (\p _ -> alex $ Keyword p KwDataprop) }     <0> assume                   { tok (\p _ -> alex $ Keyword p KwAssume) }+    <0> absimpl                  { tok (\p _ -> alex $ Keyword p KwAbsimpl) }     <0> typedef                  { tok (\p _ -> alex $ Keyword p KwTypedef) }     <0> @view typedef            { tok (\p _ -> alex $ Keyword p KwVtypedef) }     <0> absprop                  { tok (\p _ -> alex $ Keyword p KwAbsprop) }@@ -336,6 +337,7 @@              | KwDatatype              | KwDatavtype              | KwAssume+             | KwAbsimpl              | KwTypedef              | KwVtypedef              | KwVtype Addendum@@ -454,6 +456,7 @@     pretty KwDatavtype = "datavtype" -- FIXME this wrongly squashes dataviewtype     pretty KwFnx = "fnx"     pretty KwAssume = "assume"+    pretty KwAbsimpl = "absimpl"     pretty KwTypedef = "typedef"     pretty KwVtypedef = "vtypedef"     pretty (KwStaload b) = maybeSharp b "staload"

@@ -130,6 +130,7 @@     tkindef { Keyword $$ KwTKind }     as { Keyword $$ KwAs }     assume { Keyword $$ KwAssume }+    absimpl { Keyword $$ KwAbsimpl }     addrAt { Keyword $$ KwAddrAt }     viewAt { Keyword $$ KwViewAt }     symintr { Keyword $$ KwSymintr }@@ -912,6 +913,8 @@             | overload dot identifierSpace with Name { OverloadIdent $1 ('.' : (to_string $3)) $5 Nothing }             | assume identifierSpace SortArgs eq Type { Assume (Unqualified (to_string $2)) $3 $5 }             | assume Name SortArgs eq Type { Assume $2 $3 $5 }+            | absimpl identifierSpace SortArgs eq Type { AbsImpl $1 (Unqualified (to_string $2)) $3 $5 }+            | absimpl Name SortArgs eq Type { AbsImpl $1 $2 $3 $5 }             | tkindef IdentifierOr eq string { TKind $1 (Unqualified $2) $4 }             | TypeDecl { $1 }             | symintr Names { SymIntr $1 $2 }

@@ -361,6 +361,7 @@ glue AbsType{} AbsType{}           = True glue AbsType{} AbsViewType{}       = True glue AbsViewType{} AbsType{}       = True+glue AbsImpl{} AbsImpl{}           = True glue TypeDef{} TypeDef{}           = True glue Comment{} _                   = True glue (Func _ Fnx{}) (Func _ And{}) = True@@ -611,4 +612,5 @@     pretty (AndD d (SortDef _ i t))         = pretty d <+> "and" <+> text i <+> "=" <+> either pretty pretty t     pretty (MacDecl _ n is e)               = "macdef" <+> text n <> "(" <> mconcat (punctuate ", " (fmap text is)) <> ") =" <+> pretty e     pretty (ExtVar _ s e)                   = "extvar" <+> text s <+> "=" <+> pretty e+    pretty (AbsImpl _ n as e)               = "absimpl" </> pretty n <> prettySortArgs as <+> "=" </> pretty e     pretty AndD{}                           = undefined -- probably not valid syntax if we get to this point

@@ -1,16 +1,11 @@ {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} {-# LANGUAGE DeriveAnyClass             #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-} {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE DuplicateRecordFields      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE PatternSynonyms            #-}-{-# LANGUAGE TemplateHaskell            #-} {-# LANGUAGE TypeFamilies               #-}  -- | This is a module containing types to model the ATS syntax tree. As it is@@ -67,18 +62,15 @@     ) where  import           Control.Composition-import           Control.DeepSeq          (NFData)-import           Control.Monad-import           Data.Function            (on)-import           Data.Functor.Foldable    (ListF (Cons), ana, cata, embed, project)-import           Data.Functor.Foldable.TH (makeBaseFunctor)-import qualified Data.Map                 as M-import           Data.Maybe               (isJust)-import           Data.Semigroup           (Semigroup)-import           GHC.Generics             (Generic)-import           Language.ATS.Lexer       (Addendum (..))+import           Control.DeepSeq       (NFData)+import           Data.Function         (on)+import           Data.Functor.Foldable hiding (Fix (..))+import qualified Data.Map              as M+import           Data.Maybe            (isJust)+import           Data.Semigroup        (Semigroup)+import           GHC.Generics          (Generic)+import           Language.ATS.Lexer    (Addendum (..)) import           Lens.Micro-import           Lens.Micro.TH  type Fix = Either Int String @@ -97,8 +89,53 @@ data Leaf a = Leaf { _constructorUniversals :: [Universal a], name :: String, constructorArgs :: [StaticExpression a], maybeType :: Maybe (Type a) }     deriving (Show, Eq, Generic, NFData) +constructorUniversals :: Lens' (Leaf a) [Universal a]+constructorUniversals f s = fmap (\x -> s { _constructorUniversals = x}) (f (_constructorUniversals s))+ type SortArgs a = Maybe [SortArg a] +fun :: Traversal' (Declaration a) (Function a)+fun f (Func x y) = Func x <$> f y+fun _ x          = pure x++impl :: Traversal' (Declaration a) (Implementation a)+impl f (Impl x y)      = Impl x <$> f y+impl f (ProofImpl x y) = ProofImpl x <$> f y+impl _ x               = pure x++valExpression :: Traversal' (Declaration a) (Expression a)+valExpression f (Val a v p e) = Val a v p <$> f e+valExpression _ x             = pure x++prValExpr :: Traversal' (Declaration a) (Maybe (Expression a))+prValExpr f (PrVal p me t) = (\me' -> PrVal p me' t) <$> f me+prValExpr _ x              = pure x++varExpr1 :: Traversal' (Declaration a) (Maybe (Expression a))+varExpr1 f (Var t p e e') = (\e'' -> Var t p e'' e') <$> f e+varExpr1 _ x              = pure x++varExpr2 :: Traversal' (Declaration a) (Maybe (Expression a))+varExpr2 f (Var t p e e') = (\e'' -> Var t p e e'') <$> f e'+varExpr2 _ x              = pure x++andExpr :: Traversal' (Declaration a) (Expression a)+andExpr f (AndDecl t p e) = AndDecl t p <$> f e+andExpr _ x               = pure x++propLeaves :: Traversal' (Declaration a) [DataPropLeaf a]+propLeaves f (DataProp l n as pl) = DataProp l n as <$> f pl+propLeaves _ x                    = pure x++leaves :: Traversal' (Declaration a) [Leaf a]+leaves f (SumType t as l)     = SumType t as <$> f l+leaves f (SumViewType t as l) = SumViewType t as <$> f l+leaves _ x                    = pure x++comment :: Traversal' (Declaration a) String+comment f (Comment c) = Comment <$> f c+comment _ x           = pure x+ -- | Declarations for functions, values, actions, etc. data Declaration a = Func { pos :: a, _fun :: Function a }                    | Impl { implArgs :: [Arg a], _impl :: Implementation a } -- TODO do something better for implicit universals@@ -143,6 +180,7 @@                    | DataSort a String [DataSortLeaf a]                    | Exception String (Type a)                    | ExtVar a String (Expression a)+                   | AbsImpl a (Name a) (SortArgs a) (Type a)                    deriving (Show, Eq, Generic, NFData)  data DataSortLeaf a = DataSortLeaf [Universal a] (Sort a) (Maybe (Sort a))@@ -151,6 +189,12 @@ data DataPropLeaf a = DataPropLeaf { propU :: [Universal a], _propExpr1 :: Expression a, _propExpr2 :: Maybe (Expression a) }                     deriving (Show, Eq, Generic, NFData) +propExpr1 :: Lens' (DataPropLeaf a) (Expression a)+propExpr1 f s = fmap (\x -> s { _propExpr1 = x}) (f (_propExpr1 s))++propExpr2 :: Lens' (DataPropLeaf a) (Maybe (Expression a))+propExpr2 f s = fmap (\x -> s { _propExpr2 = x}) (f (_propExpr2 s))+ -- | A type for parsed ATS types data Type a = Tuple a [Type a]             | BoxTuple a [Type a]@@ -177,6 +221,66 @@             | WhereType a (Type a) String (SortArgs a) (Type a)             deriving (Show, Eq, Generic, NFData) +data TypeF a x = TupleF a [x]+               | BoxTupleF a [x]+               | NamedF (Name a)+               | ExF (Existential a) (Maybe x)+               | ForAF (Universal a) x+               | DependentF (Name a) [x]+               | UnconsumedF x+               | AsProofF x (Maybe x)+               | FromVTF x+               | MaybeValF x+               | AtExprF a x (StaticExpression a)+               | AtTypeF a x+               | ProofTypeF a [x] x+               | ConcreteTypeF (StaticExpression a)+               | RefTypeF x+               | ViewTypeF a x+               | FunctionTypeF String x x+               | NoneTypeF a+               | ImplicitTypeF a+               | ViewLiteralF Addendum+               | AnonymousRecordF a [(String, x)]+               | ParenTypeF a x+               | WhereTypeF a x String (SortArgs a) x+               deriving (Functor)++type instance Base (Type a) = TypeF a++instance Recursive (Type a) where+    project (Tuple x tys)              = TupleF x tys+    project (BoxTuple x tys)           = BoxTupleF x tys+    project (Named n)                  = NamedF n+    project (Ex e mty)                 = ExF e mty+    project (ForA u ty)                = ForAF u ty+    project (Dependent n tys)          = DependentF n tys+    project (Unconsumed ty)            = UnconsumedF ty+    project (AsProof ty mty)           = AsProofF ty mty+    project (FromVT ty)                = FromVTF ty+    project (MaybeVal ty)              = MaybeValF ty+    project (AtExpr l ty se)           = AtExprF l ty se+    project (AtType l ty)              = AtTypeF l ty+    project (ProofType l tys ty')      = ProofTypeF l tys ty'+    project (ConcreteType se)          = ConcreteTypeF se+    project (RefType ty)               = RefTypeF ty+    project (ViewType l ty)            = ViewTypeF l ty+    project (FunctionType s ty ty')    = FunctionTypeF s ty ty'+    project (NoneType l)               = NoneTypeF l+    project (ImplicitType l)           = ImplicitTypeF l+    project (ViewLiteral a)            = ViewLiteralF a+    project (AnonymousRecord l stys)   = AnonymousRecordF l stys+    project (ParenType l ty)           = ParenTypeF l ty+    project (WhereType l ty s sas ty') = WhereTypeF l ty s sas ty'++typeCall :: Traversal' (Type a) (Name a)+typeCall f (Dependent x y) = (\x' -> Dependent x' y) <$> f x+typeCall _ x               = pure x++typeCallArgs :: Traversal' (Type a) [Type a]+typeCallArgs f (Dependent x y) = (\y' -> Dependent x y') <$> f y+typeCallArgs _ x               = pure x+ -- | A type for @=>@, @=\<cloref1>@, etc. data LambdaType a = Plain a                   | Spear a -- | @=>>@@@ -194,20 +298,52 @@  -- | A data type for patterns. data Pattern a = Wildcard a-             | PName (Name a) [Pattern a]-             | PSum String (Pattern a)-             | PLiteral (Expression a)-             | Guarded a (Expression a) (Pattern a)-             | Free (Pattern a)-             | Proof a [Pattern a] [Pattern a]-             | TuplePattern [Pattern a]-             | BoxTuplePattern a [Pattern a]-             | AtPattern a (Pattern a)-             | UniversalPattern a String [Universal a] (Pattern a)-             | ExistentialPattern (Existential a) (Pattern a)-             | As a (Pattern a) (Pattern a)-             deriving (Show, Eq, Generic, NFData)+               | PName (Name a) [Pattern a]+               | PSum String (Pattern a)+               | PLiteral (Expression a)+               | Guarded a (Expression a) (Pattern a)+               | Free (Pattern a)+               | Proof a [Pattern a] [Pattern a]+               | TuplePattern [Pattern a]+               | BoxTuplePattern a [Pattern a]+               | AtPattern a (Pattern a)+               | UniversalPattern a String [Universal a] (Pattern a)+               | ExistentialPattern (Existential a) (Pattern a)+               | As a (Pattern a) (Pattern a)+               deriving (Show, Eq, Generic, NFData) +data PatternF a x = WildcardF a+                  | PNameF (Name a) [x]+                  | PSumF String x+                  | PLiteralF (Expression a)+                  | GuardedF a (Expression a) x+                  | FreeF x+                  | ProofF a [x] [x]+                  | TuplePatternF [x]+                  | BoxTuplePatternF a [x]+                  | AtPatternF a x+                  | UniversalPatternF a String [Universal a] x+                  | ExistentialPatternF (Existential a) x+                  | AsF a x x+                  deriving (Functor)++type instance Base (Pattern a) = PatternF a++instance Recursive (Pattern a) where+    project (Wildcard a)                = WildcardF a+    project (PName x ps)                = PNameF x ps+    project (PSum x p)                  = PSumF x p+    project (PLiteral e)                = PLiteralF e+    project (Guarded x e p)             = GuardedF x e p+    project (Free p)                    = FreeF p+    project (Proof x ps ps')            = ProofF x ps ps'+    project (TuplePattern ps)           = TuplePatternF ps+    project (BoxTuplePattern x ps)      = BoxTuplePatternF x ps+    project (AtPattern x p)             = AtPatternF x p+    project (UniversalPattern x s us p) = UniversalPatternF x s us p+    project (ExistentialPattern e x)    = ExistentialPatternF e x+    project (As x p p')                 = AsF x p p'+ data Paired a b = Both a b                 | First a                 | Second b@@ -234,6 +370,28 @@             | ArrowSort a (Sort a) (Sort a)             deriving (Show, Eq, Generic, NFData) +data SortF a x = NamedSortF String+               | T0pF Addendum+               | Vt0pF Addendum+               | AddrF+               | VTypeF a Addendum+               | ViewF a Addendum+               | TupleSortF a x x+               | ArrowSortF a x x+               deriving (Functor)++type instance Base (Sort a) = SortF a++instance Recursive (Sort a) where+    project (NamedSort s)      = NamedSortF s+    project (T0p a)            = T0pF a+    project (Vt0p a)           = Vt0pF a+    project Addr               = AddrF+    project (VType x a)        = VTypeF x a+    project (View x a)         = ViewF x a+    project (TupleSort x s s') = TupleSortF x s s'+    project (ArrowSort x s s') = ArrowSortF x s s'+ -- FIXME a type for sorts? -- | Wrapper for universal quantifiers (refinement types) data Universal a = Universal { bound :: [String], typeU :: Maybe (Sort a), prop :: [StaticExpression a] }@@ -278,13 +436,39 @@                         | StaticInt Int                         | SPrecede (StaticExpression a) (StaticExpression a)                         | StaticVoid a-                        | Sif { scond :: StaticExpression a, wwhenTrue :: StaticExpression a, selseExpr :: StaticExpression a } -- Static if (for proofs)+                        | Sif { scond :: StaticExpression a, whenTrue :: StaticExpression a, selseExpr :: StaticExpression a } -- Static if (for proofs)                         | SCall (Name a) [StaticExpression a]                         | SUnary (UnOp a) (StaticExpression a)                         | SLet a [Declaration a] (Maybe (StaticExpression a))                         | SCase Addendum (StaticExpression a) [(Pattern a, LambdaType a, StaticExpression a)]                         deriving (Show, Eq, Generic, NFData) +data StaticExpressionF a x = StaticValF (Name a)+                           | StaticBinaryF (BinOp a) x x+                           | StaticIntF Int+                           | SPrecedeF x x+                           | StaticVoidF a+                           | SifF x x x+                           | SCallF (Name a) [x]+                           | SUnaryF (UnOp a) x+                           | SLetF a [Declaration a] (Maybe x)+                           | SCaseF Addendum x [(Pattern a, LambdaType a, x)]+                           deriving (Functor)++type instance Base (StaticExpression a) = StaticExpressionF a++instance Recursive (StaticExpression a) where+    project (StaticVal n)         = StaticValF n+    project (StaticBinary b x x') = StaticBinaryF b x x'+    project (StaticInt i)         = StaticIntF i+    project (SPrecede x x')       = SPrecedeF x x'+    project (StaticVoid x)        = StaticVoidF x+    project (Sif e e' e'')        = SifF e e' e''+    project (SCall n es)          = SCallF n es+    project (SUnary u x)          = SUnaryF u x+    project (SLet x ds e)         = SLetF x ds e+    project (SCase a x ples)      = SCaseF a x ples+ -- | A (possibly effectful) expression. data Expression a = Let a (ATS a) (Maybe (Expression a))                   | VoidLiteral a -- ^ The '()' literal representing inaction.@@ -342,6 +526,134 @@                   | MacroVar a String                   deriving (Show, Eq, Generic, NFData) +data ExpressionF a x = LetF a (ATS a) (Maybe x)+                     | VoidLiteralF a+                     | CallF (Name a) [[Type a]] [Type a] (Maybe [x]) [x]+                     | NamedValF (Name a)+                     | ListLiteralF a String (Type a) [x]+                     | IfF x x (Maybe x)+                     | UintLitF Word+                     | FloatLitF Float+                     | IntLitF Int+                     | HexLitF String+                     | UnderscoreLitF a+                     | LambdaF a (LambdaType a) (Pattern a) x+                     | LinearLambdaF a (LambdaType a) (Pattern a) x+                     | IndexF a (Name a) x+                     | AccessF a x (Name a)+                     | StringLitF String+                     | CharLitF Char+                     | AddrAtF a x+                     | ViewAtF a x+                     | BinaryF (BinOp a) x x+                     | UnaryF (UnOp a) x+                     | IfCaseF a [(x, LambdaType a, x)]+                     | CaseF a Addendum x [(Pattern a, LambdaType a, x)]+                     | RecordValueF a [(String, x)] (Maybe (Type a))+                     | PrecedeF x x+                     | ProofExprF a x x+                     | TypeSignatureF x (Type a)+                     | WhereExpF x (ATS a)+                     | TupleExF a [x]+                     | BoxTupleExF a [x]+                     | WhileF a x x+                     | ActionsF (ATS a)+                     | BeginF a x+                     | BinListF (BinOp a) [x]+                     | PrecedeListF [x]+                     | FixAtF a String (StackFunction a)+                     | LambdaAtF a (StackFunction a)+                     | ParenExprF a x+                     | CommentExprF String x+                     | MacroVarF a String+                     deriving (Functor)++type instance Base (Expression a) = ExpressionF a++instance Recursive (Expression a) where+    project (Let l ds me)            = LetF l ds me+    project (VoidLiteral l)          = VoidLiteralF l+    project (Call n is us mps as)    = CallF n is us mps as+    project (NamedVal n)             = NamedValF n+    project (ListLiteral l s t es)   = ListLiteralF l s t es+    project (If e e' me)             = IfF e e' me+    project (UintLit u)              = UintLitF u+    project (FloatLit f)             = FloatLitF f+    project (IntLit i)               = IntLitF i+    project (HexLit s)               = HexLitF s+    project (UnderscoreLit l)        = UnderscoreLitF l+    project (Lambda l lt p e)        = LambdaF l lt p e+    project (LinearLambda l lt p e)  = LinearLambdaF l lt p e+    project (Index l n e)            = IndexF l n e+    project (Access l e n)           = AccessF l e n+    project (StringLit s)            = StringLitF s+    project (CharLit c)              = CharLitF c+    project (AddrAt l e)             = AddrAtF l e+    project (ViewAt l e)             = ViewAtF l e+    project (Binary op e e')         = BinaryF op e e'+    project (Unary op e)             = UnaryF op e+    project (IfCase l arms)          = IfCaseF l arms+    project (Case l k e arms)        = CaseF l k e arms+    project (RecordValue l recs mty) = RecordValueF l recs mty+    project (Precede e e')           = PrecedeF e e'+    project (ProofExpr a e e')       = ProofExprF a e e'+    project (TypeSignature e ty)     = TypeSignatureF e ty+    project (WhereExp e ds)          = WhereExpF e ds+    project (TupleEx l es)           = TupleExF l es+    project (BoxTupleEx l es)        = BoxTupleExF l es+    project (While l e e')           = WhileF l e e'+    project (Actions ds)             = ActionsF ds+    project (Begin l e)              = BeginF l e+    project (BinList op es)          = BinListF op es+    project (PrecedeList es)         = PrecedeListF es+    project (FixAt a s sfun)         = FixAtF a s sfun+    project (LambdaAt a sfun)        = LambdaAtF a sfun+    project (ParenExpr l e)          = ParenExprF l e+    project (CommentExpr s e)        = CommentExprF s e+    project (MacroVar l s)           = MacroVarF l s++instance Corecursive (Expression a) where+    embed (LetF l ds me)            = Let l ds me+    embed (VoidLiteralF l)          = VoidLiteral l+    embed (CallF n is us mps as)    = Call n is us mps as+    embed (NamedValF n)             = NamedVal n+    embed (ListLiteralF l s t es)   = ListLiteral l s t es+    embed (IfF e e' me)             = If e e' me+    embed (UintLitF u)              = UintLit u+    embed (IntLitF i)               = IntLit i+    embed (FloatLitF f)             = FloatLit f+    embed (HexLitF s)               = HexLit s+    embed (UnderscoreLitF l)        = UnderscoreLit l+    embed (LambdaF l lt p e)        = Lambda l lt p e+    embed (LinearLambdaF l lt p e)  = LinearLambda l lt p e+    embed (IndexF l n e)            = Index l n e+    embed (AccessF l n e)           = Access l n e+    embed (StringLitF s)            = StringLit s+    embed (CharLitF c)              = CharLit c+    embed (AddrAtF l e)             = AddrAt l e+    embed (ViewAtF l e)             = ViewAt l e+    embed (BinaryF op e e')         = Binary op e e'+    embed (UnaryF op e)             = Unary op e+    embed (IfCaseF l arms)          = IfCase l arms+    embed (CaseF l k e arms)        = Case l k e arms+    embed (RecordValueF l recs mty) = RecordValue l recs mty+    embed (PrecedeF e e')           = Precede e e'+    embed (ProofExprF a e e')       = ProofExpr a e e'+    embed (TypeSignatureF e ty)     = TypeSignature e ty+    embed (WhereExpF e ds)          = WhereExp e ds+    embed (TupleExF l es)           = TupleEx l es+    embed (BoxTupleExF l es)        = BoxTupleEx l es+    embed (WhileF l e e')           = While l e e'+    embed (ActionsF ds)             = Actions ds+    embed (BeginF l e)              = Begin l e+    embed (BinListF op es)          = BinList op es+    embed (PrecedeListF es)         = PrecedeList es+    embed (FixAtF a s sfun)         = FixAt a s sfun+    embed (LambdaAtF a sfun)        = LambdaAt a sfun+    embed (ParenExprF l e)          = ParenExpr l e+    embed (CommentExprF s e)        = CommentExpr s e+    embed (MacroVarF l s)           = MacroVar l s+ -- | An 'implement' or 'primplmnt' declaration data Implementation a = Implement { pos            :: a                                   , preUniversalsI :: [Universal a]@@ -353,6 +665,9 @@                                   }     deriving (Show, Eq, Generic, NFData) +iExpression :: Lens' (Implementation a) (Either (StaticExpression a) (Expression a))+iExpression f s = fmap (\x -> s { _iExpression = x}) (f (_iExpression s))+ -- | A function declaration accounting for all keywords ATS uses to -- define them. data Function a = Fun { _preF :: PreFunction a }@@ -365,6 +680,9 @@                 | CastFn { _preF :: PreFunction a }                 deriving (Show, Eq, Generic, NFData) +preF :: Lens' (Function a) (PreFunction a)+preF f s = fmap (\x -> s { _preF = x}) (f (_preF s))+ -- | A type for stack-allocated functions. See -- [here](http://ats-lang.sourceforge.net/DOCUMENT/ATS2TUTORIAL/HTML/c1267.html) -- for more.@@ -386,8 +704,9 @@                           }                           deriving (Show, Eq, Generic, NFData) -join <$> traverse makeBaseFunctor [''Pattern, ''Expression, ''StaticExpression, ''Type, ''Sort]-join <$> traverse makeLenses [''Leaf, ''Declaration, ''PreFunction, ''Implementation, ''DataPropLeaf, ''Function, ''Type]+-- TODO lens/base functor module?+expression :: Lens' (PreFunction a) (Maybe (Expression a))+expression f s = fmap (\x -> s { _expression = x}) (f (_expression s))  exprLens :: Eq a => FixityState a -> ASetter s t (Expression a) (Expression a) -> s -> t exprLens st = flip over (rewriteATS st)

@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +import           Data.Foldable import qualified Filesystem.Path.CurrentOS as F import           Language.ATS import           Test.Hspec@@ -11,5 +12,5 @@ main :: IO () main = hspec $     describe "pretty-print" $ parallel $-        mapM_ (\x -> testFiles x isATS (fmap printATS . parse))+        traverse_ (\x -> testFiles x isATS (fmap printATS . parse))             ["test/data", "test/data/stdlib", "test/data/stdlib/DATS"]