diff --git a/Justfile b/Justfile --- a/Justfile +++ b/Justfile @@ -29,7 +29,7 @@ @poly . -e data/ bench: - bench "atsfmt test/data/polyglot.dats" "atsfmt test/data/left-pad.dats" "atsfmt ~/programming/ats/toml-parse/src/toml-parse.dats" + bench "atsfmt test/data/polyglot.dats" "atsfmt test/data/left-pad.dats" "atsfmt ~/programming/ats/toml-parse/src/vml-parse.dats" manpages: pandoc man/MANPAGE.md -s -t man -o man/atsfmt.1 diff --git a/ats-format.cabal b/ats-format.cabal --- a/ats-format.cabal +++ b/ats-format.cabal @@ -1,14 +1,14 @@ name: ats-format -version: 0.1.0.19 +version: 0.1.0.20 synopsis: A source-code formatter for ATS -description: An opinionated source-code formatter for ATS (http://www.ats-lang.org/). +description: An opinionated source-code formatter for [ATS](http://www.ats-lang.org/). homepage: https://hub.darcs.net/vmchale/ats-format#readme license: BSD3 license-file: LICENSE author: Vanessa McHale maintainer: vamchale@gmail.com copyright: Copyright: (c) 2017 Vanessa McHale -category: Parser, Language +category: Parser, Language, ATS, Development build-type: Custom extra-doc-files: README.md data-files: .travis.yml @@ -41,7 +41,6 @@ , Language.ATS.Parser , Language.ATS.PrettyPrint , Language.ATS.Exec - , Language.ATS.Doc , Paths_ats_format build-depends: base >= 4.8 && < 5 , array @@ -56,8 +55,6 @@ , megaparsec , unordered-containers , text - , blaze-markup - , blaze-html , directory , process , file-embed @@ -89,12 +86,8 @@ build-depends: base , ats-format , hspec - , dirstream - , pipes + , hspec-dirstream , system-filepath - , pipes-safe - , filepath - , hspec-core if flag(development) ghc-options: -Werror if impl(ghc >= 8.0) diff --git a/src/Language/ATS.hs b/src/Language/ATS.hs --- a/src/Language/ATS.hs +++ b/src/Language/ATS.hs @@ -3,8 +3,6 @@ lexATS , parseATS , printATS - -- * Documentation generation - , generateATSDocs -- * Syntax Tree , ATS (..) , Declaration (..) @@ -32,11 +30,13 @@ , Keyword (..) -- * Error types , ATSError + -- * Lenses + , leaves + , constructorUniversals -- * Executable , exec ) where -import Language.ATS.Doc import Language.ATS.Exec import Language.ATS.Lexer import Language.ATS.Parser diff --git a/src/Language/ATS/Doc.hs b/src/Language/ATS/Doc.hs deleted file mode 100644 --- a/src/Language/ATS/Doc.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.ATS.Doc ( generateATSDocs - ) where - -import Language.ATS.Types -import Text.Blaze.Html5 - -generateATSDocs :: ATS -> Html -generateATSDocs = toHtml . markupATS - -markupATS :: ATS -> Markup -markupATS _ = html $ - body $ do - p "First paragraph" - p "Second paragraph" diff --git a/src/Language/ATS/Parser.y b/src/Language/ATS/Parser.y --- a/src/Language/ATS/Parser.y +++ b/src/Language/ATS/Parser.y @@ -464,7 +464,7 @@ | Leaves SumLeaf { $2 : $1 } | Universals identifierSpace of Type { [Leaf $1 $2 [] (Just $4)] } | Universals identifier { [Leaf $1 $2 [] Nothing] } - | Universals identifier openParen IdentifiersIn closeParen OfType { [Leaf $1 $2 $4 $6] } + | Universals identifier openParen IdentifiersIn closeParen OfType { [Leaf $1 $2 $4 $6] } -- FIXME should take any static expression. | dollar {% Left $ Expected $1 "|" "$" } Universals : { [] } diff --git a/src/Language/ATS/PrettyPrint.hs b/src/Language/ATS/PrettyPrint.hs --- a/src/Language/ATS/PrettyPrint.hs +++ b/src/Language/ATS/PrettyPrint.hs @@ -143,15 +143,15 @@ | otherwise = e <+> pretty op <+> e' a (IndexF _ n e) = pretty n <> "[" <> e <> "]" a (UnaryF Negate e) = "~" <> e - a (NamedValF name) = pretty name - a (CallF name [] [] Nothing []) = pretty name <> "()" - a (CallF name [] [] (Just e) xs) = pretty name <> prettyArgsG ("(" <> pretty e <+> "| ") ")" xs -- FIXME split eagerly on "|" - a (CallF name [] [] Nothing xs) = pretty name <> prettyArgsG "(" ")" xs - a (CallF name [] us Nothing []) = pretty name <> prettyArgsU "{" "}" us - a (CallF name is [] Nothing []) = pretty name <> prettyArgsU "<" ">" is - a (CallF name is [] Nothing [x]) - | startsParens x = pretty name <> prettyArgsU "<" ">" is <> pretty x - a (CallF name is [] Nothing xs) = pretty name <> prettyArgsU "<" ">" is <> prettyArgsG "(" ")" xs + a (NamedValF nam) = pretty nam + a (CallF nam [] [] Nothing []) = pretty nam <> "()" + a (CallF nam [] [] (Just e) xs) = pretty nam <> prettyArgsG ("(" <> pretty e <+> "| ") ")" xs -- FIXME split eagerly on "|" + a (CallF nam [] [] Nothing xs) = pretty nam <> prettyArgsG "(" ")" xs + a (CallF nam [] us Nothing []) = pretty nam <> prettyArgsU "{" "}" us + a (CallF nam is [] Nothing []) = pretty nam <> prettyArgsU "<" ">" is + a (CallF nam is [] Nothing [x]) + | startsParens x = pretty nam <> prettyArgsU "<" ">" is <> pretty x + a (CallF nam is [] Nothing xs) = pretty nam <> prettyArgsU "<" ">" is <> prettyArgsG "(" ")" xs a (CaseF _ add e cs) = "case" <> pretty add <+> e <+> "of" <$> indent 2 (prettyCases cs) a (VoidLiteralF _) = "()" a (RecordValueF _ es Nothing) = prettyRecord es @@ -294,7 +294,7 @@ go _ = "FIXME" instance Pretty ATS where - pretty (ATS xs) = concatSame xs + pretty (ATS xs) = concatSame (fmap rewriteDecl xs) instance Pretty Implementation where pretty (Implement _ [] [] n [] e) = "implement" <+> pretty n <+> "() =" <$> indent 2 (pretty e) diff --git a/src/Language/ATS/Types.hs b/src/Language/ATS/Types.hs --- a/src/Language/ATS/Types.hs +++ b/src/Language/ATS/Types.hs @@ -38,11 +38,17 @@ , StaticExpression (..) , StaticExpressionF (..) , rewriteATS + , rewriteDecl + -- * Lenses + , leaves + , constructorUniversals ) where import Control.DeepSeq (NFData) -import Data.Functor.Foldable (cata, embed) +import Control.Lens +import Data.Functor.Foldable (ListF (Cons), ana, cata, embed, project) import Data.Functor.Foldable.TH (makeBaseFunctor) +import Data.Maybe (isJust) import GHC.Generics (Generic) import Language.ATS.Lexer (Addendum (..), AlexPosn) @@ -54,7 +60,7 @@ newtype ATS = ATS { unATS :: [Declaration] } deriving (Show, Eq, Generic, NFData) -data Leaf = Leaf [Universal] String [String] (Maybe Type) +data Leaf = Leaf { _constructorUniversals :: [Universal], name :: String, constructorArgs :: [String], maybeType :: Maybe Type } deriving (Show, Eq, Generic, NFData) -- | Declare something in a scope (a function, value, action, etc.) @@ -73,8 +79,8 @@ | RecordViewType String [Arg] [Universal] [(String, Type)] | TypeDef AlexPosn String [Arg] Type | ViewTypeDef AlexPosn String [Arg] Type - | SumType String [Arg] [Leaf] - | SumViewType String [Arg] [Leaf] + | SumType { typeName :: String, typeArgs :: [Arg], _leaves :: [Leaf] } + | SumViewType { typeName :: String, typeArgs :: [Arg], _leaves :: [Leaf] } | AbsType AlexPosn String [Arg] (Maybe Type) | AbsViewType AlexPosn String [Arg] (Maybe Type) | AbsView AlexPosn String [Arg] (Maybe Type) @@ -135,13 +141,13 @@ | ViewLiteral Addendum deriving (Show, Eq, Generic, NFData) --- | A type for the various lambda arrows (`=>`, `=`, etc.) +-- | A type for the various lambda arrows (@=>@, @=@, etc.) data LambdaType = Plain AlexPosn | Full AlexPosn String | Spear AlexPosn deriving (Show, Eq, Generic, NFData) --- | A name can be qualified (`$UN.unsafefn`) or not +-- | A name can be qualified (@$UN.unsafefn@) or not data Name = Unqualified String | Qualified AlexPosn String String | SpecialName AlexPosn String @@ -173,14 +179,14 @@ deriving (Show, Eq, Generic, NFData) -- | Wrapper for universal quantifiers (refinement types) -data Universal = Universal { bound :: [Arg], typeU :: Maybe Type, prop :: Maybe StaticExpression } +data Universal = Universal { bound :: [Arg], typeU :: Maybe Type, prop :: Maybe StaticExpression } -- TODO NonEmpty type? deriving (Show, Eq, Generic, NFData) -- | Wrapper for existential quantifiers/types data Existential = Existential { boundE :: [Arg], typeE :: Maybe Type, propE :: Maybe Expression } -- TODO #[id:int] existentials deriving (Show, Eq, Generic, NFData) --- | `~` is used to negate numbers in ATS +-- | @~@ is used to negate numbers in ATS data UnOp = Negate deriving (Show, Eq, Generic, NFData) @@ -241,7 +247,7 @@ | Case { posE :: AlexPosn , kind :: Addendum , val :: Expression - , arms :: [(Pattern, LambdaType, Expression)] -- ^ Each `(Pattern, Expression)` pair corresponds to a branch of the 'case' statement + , arms :: [(Pattern, LambdaType, Expression)] -- ^ Each @(Pattern, Expression)@ pair corresponds to a branch of the 'case' statement } | RecordValue AlexPosn [(String, Expression)] (Maybe Type) | Precede Expression Expression @@ -303,6 +309,19 @@ makeBaseFunctor ''Expression makeBaseFunctor ''StaticExpression makeBaseFunctor ''Type +makeLenses ''Leaf +makeLenses ''Declaration + +rewriteDecl :: Declaration -> Declaration +rewriteDecl x@SumViewType{} = g x + where g = over (leaves.mapped.constructorUniversals) h + h :: [Universal] -> [Universal] + h = ana c where + c (y:y':ys) + | typeU y == typeU y' && isJust (typeU y) = + Cons (Universal (bound y ++ bound y') (typeU y) (StaticBinary LogicalAnd <$> prop y <*> prop y')) ys + c y = project y +rewriteDecl x = x -- precedence: rewrite n + 2 * x to n + (2 * x) -- TODO: rewrite multiple universals when it's the right context? diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -4,8 +4,8 @@ - '.' extra-deps: - ansi-wl-pprint-0.6.8.1 - - htoml-megaparsec-1.0.1.11 - - composition-prelude-0.1.1.2 + - htoml-megaparsec-1.0.1.12 + - composition-prelude-0.1.1.4 - dirstream-1.0.3 flags: ats-format: diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,41 +1,14 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE OverloadedStrings #-} -import Data.DirStream import qualified Filesystem.Path.CurrentOS as F import Language.ATS -import Pipes -import qualified Pipes.Prelude as P -import Pipes.Safe -import System.FilePath import Test.Hspec -import Test.Hspec.Core.Spec - -deriving instance MonadCatch (SpecM a) -deriving instance MonadThrow (SpecM a) -deriving instance MonadMask (SpecM a) -deriving instance MonadIO (SpecM a) +import Test.Hspec.Dirstream isATS :: F.FilePath -> Bool -isATS x = (F.extension x `elem`) (pure <$> ["ats", "dats", "sats", "hats", "cats"]) - -testFile :: String -> SpecWith () -testFile f = it f $ do - sample <- readFile f - expected <- readFile (replaceExtension f ".out") - (fmap printATS . parseATS . lexATS) sample `shouldBe` Right expected +isATS x = (extension x `elem`) (pure <$> ["ats", "dats", "sats", "hats", "cats"]) main :: IO () main = hspec $ describe "pretty-print" $ parallel $ - runSafeT $ runEffect $ atsPath >-> mapS testFile - -mapS :: (a -> SpecM () ()) -> Proxy () a y' y (SafeT (SpecM ())) r -mapS = P.mapM_ . (lift .) - -atsPath :: MonadSafe m => Producer String m () -atsPath = every (childOf p) >-> P.filter isATS >-> P.map F.encodeString - where p = F.decodeString "test/data" + testFiles "test/data" isATS (fmap printATS . parseATS . lexATS)