Skip to content

Commit

Permalink
release
Browse files Browse the repository at this point in the history
  • Loading branch information
Vanessa McHale committed Jul 28, 2018
1 parent 783ca4a commit 1c8f90d
Show file tree
Hide file tree
Showing 9 changed files with 46 additions and 36 deletions.
2 changes: 1 addition & 1 deletion ats-pkg/ats-pkg.cabal
View file
Original file line number Diff line number Diff line change
@@ -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
Expand Down
2 changes: 1 addition & 1 deletion hs2ats/hs2ats.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down
7 changes: 5 additions & 2 deletions hs2ats/src/Language/ATS/Generate.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
6 changes: 6 additions & 0 deletions hs2ats/src/Language/ATS/Generate/Error.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,7 @@ module Language.ATS.Generate.Error ( -- * Types
-- * Helper functions
, unsupported
, syntaxError
, malformed
) where

import Control.Composition
Expand All @@ -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
2 changes: 1 addition & 1 deletion language-ats/language-ats.cabal
View file
Original file line number Diff line number Diff line change
@@ -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
Expand Down
26 changes: 13 additions & 13 deletions language-ats/src/Language/ATS/Parser.y
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 }

Expand Down Expand Up @@ -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 }

Expand All @@ -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 : { [] }
Expand Down Expand Up @@ -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 }
Expand Down
18 changes: 9 additions & 9 deletions language-ats/src/Language/ATS/PrettyPrint.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..))
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
16 changes: 8 additions & 8 deletions language-ats/src/Language/ATS/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand All @@ -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))
Expand All @@ -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)
Expand Down Expand Up @@ -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)
Expand All @@ -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)
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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)
Expand Down
3 changes: 2 additions & 1 deletion language-ats/src/Language/ATS/Types/Lens.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@ module Language.ATS.Types.Lens ( -- * Lenses
, comment
) where

import Data.List.NonEmpty (NonEmpty)
import Language.ATS.Types
import Lens.Micro

Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 1c8f90d

Please sign in to comment.