From 1c8f90ddbd8de3c91efe0dcde397c8864362d53e Mon Sep 17 00:00:00 2001 From: Vanessa McHale Date: Fri, 27 Jul 2018 19:48:28 -0500 Subject: [PATCH] release --- ats-pkg/ats-pkg.cabal | 2 +- hs2ats/hs2ats.cabal | 2 +- hs2ats/src/Language/ATS/Generate.hs | 7 ++++-- hs2ats/src/Language/ATS/Generate/Error.hs | 6 +++++ language-ats/language-ats.cabal | 2 +- language-ats/src/Language/ATS/Parser.y | 26 ++++++++++---------- language-ats/src/Language/ATS/PrettyPrint.hs | 18 +++++++------- language-ats/src/Language/ATS/Types.hs | 16 ++++++------ language-ats/src/Language/ATS/Types/Lens.hs | 3 ++- 9 files changed, 46 insertions(+), 36 deletions(-) diff --git a/ats-pkg/ats-pkg.cabal b/ats-pkg/ats-pkg.cabal index 6be830e8..2dc801da 100644 --- a/ats-pkg/ats-pkg.cabal +++ b/ats-pkg/ats-pkg.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: ats-pkg -version: 3.1.0.2 +version: 3.1.0.3 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018 Vanessa McHale diff --git a/hs2ats/hs2ats.cabal b/hs2ats/hs2ats.cabal index 28ba0128..07794b46 100644 --- a/hs2ats/hs2ats.cabal +++ b/hs2ats/hs2ats.cabal @@ -35,7 +35,7 @@ library build-depends: base >=4.7 && <5, haskell-src-exts -any, - language-ats >=1.4.0.0, + language-ats >=1.5.0.0, casing -any, microlens -any, ansi-wl-pprint -any, diff --git a/hs2ats/src/Language/ATS/Generate.hs b/hs2ats/src/Language/ATS/Generate.hs index 05dc3862..7ed8166b 100644 --- a/hs2ats/src/Language/ATS/Generate.hs +++ b/hs2ats/src/Language/ATS/Generate.hs @@ -14,6 +14,7 @@ import Data.Bool (bool) import Data.Char (toUpper) import Data.Either (lefts, rights) import Data.Foldable +import qualified Data.List.NonEmpty as NE import Data.Maybe import Language.ATS as ATS import Language.ATS.Generate.Error @@ -93,7 +94,8 @@ conDeclToType :: ConDecl a -> ErrM (String, Maybe (ATS.Type b)) conDeclToType (ConDecl _ n []) = Right (toStringATS n, Nothing) conDeclToType (ConDecl _ n [t]) = (,) (toStringATS n) . Just <$> typeToType t conDeclToType (ConDecl _ n ts) = (,) (toStringATS n) . Just . ATS.Tuple undefined <$> traverse typeToType ts -conDeclToType (RecDecl _ n fs) = (,) (toStringATS n) . Just . AnonymousRecord undefined <$> traverse fieldDeclToType (reverse fs) +conDeclToType (RecDecl _ _ []) = malformed "conDeclToType" +conDeclToType (RecDecl _ n fs) = (,) (toStringATS n) . Just . AnonymousRecord undefined <$> traverse fieldDeclToType (NE.fromList (reverse fs)) conDeclToType _ = unsupported "conDeclToType" toStringATS :: HS.Name a -> String @@ -129,9 +131,10 @@ pruneATSNils x = Just x -- TODO if it derives functor, use + asATSType :: Decl a -> ErrM (Declaration b) asATSType (TypeDecl _ dh t) = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (pruneATSNils . snd <$> asATSName dh) <*> typeToType t +asATSType (DataDecl _ DataType{} _ _ [] _) = malformed "asATSType" asATSType (DataDecl _ NewType{} _ dh [qcd] _) = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (pruneATSNils . snd <$> asATSName dh) <*> qualConDeclToType qcd asATSType (DataDecl _ DataType{} _ dh [qcd] _) = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (pruneATSNils . snd <$> asATSName dh) <*> qualConDeclToType qcd -asATSType (DataDecl _ DataType{} _ dh qcds _) = SumViewType <$> (fst <$> asATSName dh) <*> (pruneATSNils . snd <$> asATSName dh) <*> traverse qualConDeclToLeaf (reverse qcds) +asATSType (DataDecl _ DataType{} _ dh qcds _) = SumViewType <$> (fst <$> asATSName dh) <*> (pruneATSNils . snd <$> asATSName dh) <*> traverse qualConDeclToLeaf (NE.fromList (reverse qcds)) asATSType _ = unsupported "asATSType" -- TODO GDataDecl diff --git a/hs2ats/src/Language/ATS/Generate/Error.hs b/hs2ats/src/Language/ATS/Generate/Error.hs index 9e01b05f..e11fc374 100644 --- a/hs2ats/src/Language/ATS/Generate/Error.hs +++ b/hs2ats/src/Language/ATS/Generate/Error.hs @@ -12,6 +12,7 @@ module Language.ATS.Generate.Error ( -- * Types -- * Helper functions , unsupported , syntaxError + , malformed ) where import Control.Composition @@ -34,12 +35,17 @@ syntaxError = Left .* HaskellSyntaxError unsupported :: String -> ErrM a unsupported = Left . Unsupported +malformed :: String -> ErrM a +malformed = Left . Malformed + data GenerateError = Unsupported String | HaskellSyntaxError SrcLoc String | Internal String + | Malformed String deriving (Eq, Show, Generic, NFData) instance Pretty GenerateError where pretty (Unsupported s) = dullyellow "Warning:" <+> "skipping unsupported construct" <$$> indent 2 (squotes (text s)) <> linebreak pretty (HaskellSyntaxError loc s) = dullred "Error:" <+> "failed to parse" <+> text (show loc) <> colon <$$> indent 2 (text s) <> linebreak pretty (Internal s) = dullred "Error:" <+> "internal error: " <$$> indent 2 (text s) <> linebreak + pretty (Malformed s) = dullred "Error:" <+> "incompatible type" <$$> indent 2 (squotes (text s)) <> linebreak diff --git a/language-ats/language-ats.cabal b/language-ats/language-ats.cabal index 347356af..c5401b1e 100644 --- a/language-ats/language-ats.cabal +++ b/language-ats/language-ats.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: language-ats -version: 1.4.0.0 +version: 1.5.0.0 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018 Vanessa McHale diff --git a/language-ats/src/Language/ATS/Parser.y b/language-ats/src/Language/ATS/Parser.y index e9381cc0..d70ac00c 100644 --- a/language-ats/src/Language/ATS/Parser.y +++ b/language-ats/src/Language/ATS/Parser.y @@ -556,8 +556,8 @@ Universal : lbrace QuantifierArgs rbrace { Universal $2 Nothing [] } Implicits : lspecial TypeIn rbracket { [toList $2] } | Implicits lspecial TypeIn rbracket { toList $3 : $1 } - | doubleBrackets { [[Named (Unqualified "")]] } - | Implicits doubleBrackets { [Named (Unqualified "")] : $1 } + | doubleBrackets { [[]] } + | Implicits doubleBrackets { [] : $1 } | lbracket TypeIn rbracket { [toList $2] } | Implicits lspecial TypeIn rbracket { toList $3 : $1 } @@ -594,13 +594,13 @@ Name : identifier { Unqualified (to_string $1) } | dollar {% left $ Expected $1 "Name" "$" } -- | Parse a list of values in a record -RecordVal : IdentifierOr eq Expression { [($1, $3)] } - | RecordVal comma IdentifierOr eq Expression { ($3, $5) : $1 } +RecordVal : IdentifierOr eq Expression { ($1, $3) :| [] } + | RecordVal comma IdentifierOr eq Expression { ($3, $5) :| toList $1 } | IdentifierOr eq comma {% left $ Expected $3 "Expression" "," } -- | Parse a list of types in a record -Records : IdentifierOr eq Type { [($1, $3)] } - | Records comma IdentifierOr eq Type { ($3, $5) : $1 } +Records : IdentifierOr eq Type { ($1, $3) :| [] } + | Records comma IdentifierOr eq Type { ($3, $5) :| toList $1 } IdentifiersIn : comma_sep(IdentifierOr) { toList $1 } @@ -615,11 +615,11 @@ SumLeaf : vbar Universals identifier { Leaf $2 (to_string $3) [] Nothing } | vbar Universals IdentifierOr openParen StaticExpressionsIn closeParen OfType { Leaf $2 $3 $5 $7 } -- FIXME could also be e.g. '0' (static expression) -- | Parse all constructors of a sum type -Leaves : SumLeaf { [$1] } - | Leaves SumLeaf { $2 : $1 } - | Universals identifierSpace of Type { [Leaf $1 (to_string $2) [] (Just $4)] } - | Universals identifier { [Leaf $1 (to_string $2) [] Nothing] } - | Universals identifier openParen StaticExpressionsIn closeParen OfType { [Leaf $1 (to_string $2) $4 $6] } +Leaves : SumLeaf { $1 :| [] } + | Leaves SumLeaf { $2 :| toList $1 } + | Universals identifierSpace of Type { Leaf $1 (to_string $2) [] (Just $4) :| [] } + | Universals identifier { Leaf $1 (to_string $2) [] Nothing :| [] } + | Universals identifier openParen StaticExpressionsIn closeParen OfType { Leaf $1 (to_string $2) $4 $6 :| [] } | dollar {% left $ Expected $1 "|" "$" } PreUniversals : { [] } @@ -871,8 +871,8 @@ DataSortLeaf : vbar Universals Sort { DataSortLeaf $2 $3 Nothing } | vbar Universals Sort of Sort { DataSortLeaf $2 $3 (Just $5) } | DataSortLeaf Comment { $1 } -DataSortLeaves : DataSortLeaf { [$1] } - | DataSortLeaves DataSortLeaf { $2 : $1 } +DataSortLeaves : DataSortLeaf { $1 :| [] } + | DataSortLeaves DataSortLeaf { $2 :| toList $1 } CommentContents : commentContents { Comment $1 } | CommentContents commentContents { over comment (<> $2) $1 } diff --git a/language-ats/src/Language/ATS/PrettyPrint.hs b/language-ats/src/Language/ATS/PrettyPrint.hs index bcd8e05d..81749ea2 100644 --- a/language-ats/src/Language/ATS/PrettyPrint.hs +++ b/language-ats/src/Language/ATS/PrettyPrint.hs @@ -14,7 +14,7 @@ module Language.ATS.PrettyPrint ( printATS import Control.Composition hiding ((&)) import Data.Bool (bool) -import Data.Foldable (toList) +import Data.Foldable (fold, toList) import Data.Functor.Foldable (cata) import Data.List (isPrefixOf) import Data.List.NonEmpty (NonEmpty (..)) @@ -195,7 +195,7 @@ instance Eq a => Pretty (Expression a) where a (MacroVarF _ s) = ",(" <> text s <> ")" a BinListF{} = undefined -- Shouldn't happen - prettyImplicits = mconcat . fmap (prettyArgsU "<" ">") . reverse + prettyImplicits = fold . fmap (prettyArgsU "<" ">") . reverse prettyIfCase [] = mempty prettyIfCase [(s, l, t)] = "|" <+> s <+> pretty l <+> t @@ -404,10 +404,10 @@ lineAlt = group .* flatAlt showFast :: Doc -> String showFast d = displayS (renderCompact d) mempty -prettyRecord :: (Pretty a) => [(String, a)] -> Doc +prettyRecord :: (Pretty a) => NonEmpty (String, a) -> Doc prettyRecord es - | any ((>40) . length . showFast . pretty) es = prettyRecordF True es - | otherwise = lineAlt (prettyRecordF True es) (prettyRecordS True es) + | any ((>40) . length . showFast . pretty) es = prettyRecordF True (toList es) + | otherwise = lineAlt (prettyRecordF True (toList es)) (prettyRecordS True (toList es)) prettyRecordS :: (Pretty a) => Bool -> [(String, a)] -> Doc prettyRecordS _ [] = mempty @@ -565,10 +565,10 @@ instance Eq a => Pretty (Declaration a) where pretty (AbsType _ s as t) = "abstype" <+> text s <> prettySortArgs as <> prettyMaybeType t pretty (AbsViewType _ s as Nothing) = "absvtype" <+> text s <> prettySortArgs as pretty (AbsViewType _ s as (Just t)) = "absvtype" <+> text s <> prettySortArgs as <+> "=" <+> pretty t - pretty (SumViewType s as ls) = "datavtype" <+> text s <> prettySortArgs as <+> "=" <$> prettyLeaf ls - pretty (DataView _ s as ls) = "dataview" <+> text s <> prettySortArgs as <+> "=" <$> prettyLeaf ls - pretty (SumType s as ls) = "datatype" <+> text s <> prettySortArgs as <+> "=" <$> prettyLeaf ls - pretty (DataSort _ s ls) = "datasort" <+> text s <+> "=" <$> prettyDSL ls + pretty (SumViewType s as ls) = "datavtype" <+> text s <> prettySortArgs as <+> "=" <$> prettyLeaf (toList ls) + pretty (DataView _ s as ls) = "dataview" <+> text s <> prettySortArgs as <+> "=" <$> prettyLeaf (toList ls) + pretty (SumType s as ls) = "datatype" <+> text s <> prettySortArgs as <+> "=" <$> prettyLeaf (toList ls) + pretty (DataSort _ s ls) = "datasort" <+> text s <+> "=" <$> prettyDSL (toList ls) pretty (Impl as i) = "implement" <+> prettyArgsNil as <> pretty i pretty (ProofImpl as i) = "primplmnt" <+> prettyArgsNil as <> pretty i pretty (PrVal p (Just e) Nothing) = "prval" <+> pretty p <+> "=" <+> pretty e diff --git a/language-ats/src/Language/ATS/Types.hs b/language-ats/src/Language/ATS/Types.hs index a6df9eff..0dbcf233 100644 --- a/language-ats/src/Language/ATS/Types.hs +++ b/language-ats/src/Language/ATS/Types.hs @@ -94,8 +94,8 @@ data Declaration a = Func { pos :: a, _fun :: Function a } | CBlock String | TypeDef a String (SortArgs a) (Type a) (Maybe (Sort a)) | ViewTypeDef a String (SortArgs a) (Type a) - | SumType { typeName :: String, typeArgs :: SortArgs a, _leaves :: [Leaf a] } - | SumViewType { typeName :: String, typeArgs :: SortArgs a, _leaves :: [Leaf a] } + | SumType { typeName :: String, typeArgs :: SortArgs a, _leaves :: NonEmpty (Leaf a) } + | SumViewType { typeName :: String, typeArgs :: SortArgs a, _leaves :: NonEmpty (Leaf a) } | AbsType a String (SortArgs a) (Maybe (Type a)) | AbsViewType a String (SortArgs a) (Maybe (Type a)) | AbsView a String (SortArgs a) (Maybe (Type a)) @@ -106,7 +106,7 @@ data Declaration a = Func { pos :: a, _fun :: Function a } | OverloadIdent a String (Name a) (Maybe Int) | Comment { _comment :: String } | DataProp { pos :: a, propName :: String, propArgs :: SortArgs a, _propLeaves :: [DataPropLeaf a] } - | DataView a String (SortArgs a) [Leaf a] + | DataView a String (SortArgs a) (NonEmpty (Leaf a)) | Extern a (Declaration a) | Define String | SortDef a String (Either (Sort a) (Universal a)) @@ -120,7 +120,7 @@ data Declaration a = Func { pos :: a, _fun :: Function a } | PropDef a String (Args a) (Type a) | FixityDecl (Fixity a) [String] | MacDecl a String [String] (Expression a) - | DataSort a String [DataSortLeaf a] + | DataSort a String (NonEmpty (DataSortLeaf a)) | Exception String (Type a) | ExtVar a String (Expression a) | AbsImpl a (Name a) (SortArgs a) (Type a) @@ -152,7 +152,7 @@ data Type a = Tuple a [Type a] | FunctionType String (Type a) (Type a) | ImplicitType a | ViewLiteral Addendum - | AnonymousRecord a [(String, Type a)] + | AnonymousRecord a (NonEmpty (String, Type a)) | ParenType a (Type a) | WhereType a (Type a) String (SortArgs a) (Type a) deriving (Show, Eq, Generic, NFData) @@ -176,7 +176,7 @@ data TypeF a x = TupleF a [x] | FunctionTypeF String x x | ImplicitTypeF a | ViewLiteralF Addendum - | AnonymousRecordF a [(String, x)] + | AnonymousRecordF a (NonEmpty (String, x)) | ParenTypeF a x | WhereTypeF a x String (SortArgs a) x deriving (Functor) @@ -431,7 +431,7 @@ data Expression a = Let a (ATS a) (Maybe (Expression a)) , val :: Expression a , _arms :: [(Pattern a, LambdaType a, Expression a)] -- ^ Each (('Pattern' a), ('Expression' a)) pair corresponds to a branch of the 'case' statement } - | RecordValue a [(String, Expression a)] (Maybe (Type a)) + | RecordValue a (NonEmpty (String, Expression a)) (Maybe (Type a)) | Precede (Expression a) (Expression a) | ProofExpr a (NonEmpty (Expression a)) (Expression a) | TypeSignature (Expression a) (Type a) @@ -476,7 +476,7 @@ data ExpressionF a x = LetF a (ATS a) (Maybe 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)) + | RecordValueF a (NonEmpty (String, x)) (Maybe (Type a)) | PrecedeF x x | ProofExprF a (NonEmpty x) x | TypeSignatureF x (Type a) diff --git a/language-ats/src/Language/ATS/Types/Lens.hs b/language-ats/src/Language/ATS/Types/Lens.hs index 2d9503ea..7e58a0f9 100644 --- a/language-ats/src/Language/ATS/Types/Lens.hs +++ b/language-ats/src/Language/ATS/Types/Lens.hs @@ -20,6 +20,7 @@ module Language.ATS.Types.Lens ( -- * Lenses , comment ) where +import Data.List.NonEmpty (NonEmpty) import Language.ATS.Types import Lens.Micro @@ -83,7 +84,7 @@ 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 :: Traversal' (Declaration a) (NonEmpty (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