diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,12 +0,0 @@ -# hs2ats - -This is a tool to convert Haskell types to ATS types. So far it works quite -well, but documentation is sparse. - -Example use: - -``` -hs2ats --src DataTypes.hs --target generated_types.sats -``` - -Note also that `hs2ats` does not preserve strictness semantics. diff --git a/hs2ats.cabal b/hs2ats.cabal --- a/hs2ats.cabal +++ b/hs2ats.cabal @@ -1,5 +1,5 @@ name: hs2ats -version: 0.2.1.5 +version: 0.2.1.6 synopsis: Create ATS types from Haskell types description: This package enables scanning Haskell source files for data types and then generating [ATS](http://www.ats-lang.org/) types from them. homepage: https://github.com/vmchale/hs2ats#readme @@ -10,7 +10,6 @@ copyright: Copyright: (c) 2018 Vanessa McHale category: Language, Haskell, ATS build-type: Simple -extra-doc-files: README.md cabal-version: 1.18 Flag development { @@ -25,9 +24,8 @@ , Language.ATS.Generate.Error build-depends: base >= 4.7 && < 5 , haskell-src-exts - , language-ats - , text - , cases + , language-ats >= 1.0.0.0 + , casing , lens , optparse-generic , ansi-wl-pprint diff --git a/src/Language/ATS/Generate.hs b/src/Language/ATS/Generate.hs --- a/src/Language/ATS/Generate.hs +++ b/src/Language/ATS/Generate.hs @@ -12,20 +12,19 @@ , ErrM ) where -import Cases (snakify) import Control.Arrow import Control.Lens (over, _head) import Data.Bool (bool) import Data.Char (toUpper) import Data.Either (lefts, rights) import Data.Maybe -import qualified Data.Text as T import Language.ATS as ATS import Language.ATS.Generate.Error import Language.Haskell.Exts import Language.Haskell.Exts.Syntax as HS import Language.Preprocessor.Cpphs (defaultCpphsOptions, runCpphs) import Options.Generic +import Text.Casing (quietSnake) data Program = Program { src :: FilePath "Haskell source file" , target :: FilePath "ATS target" @@ -33,7 +32,7 @@ } deriving (Generic, ParseRecord) convertConventions :: String -> String -convertConventions = filterKeys . T.unpack . snakify . T.pack +convertConventions = filterKeys . quietSnake pattern QNamed :: l -> l -> String -> QName l pattern QNamed x y s = UnQual x (Ident y s) @@ -69,20 +68,19 @@ stringTypeConv "CBool" = Right "bool" stringTypeConv _ = unsupported "stringTypeConv" -toStringATS' :: QName a -> ErrM ATS.Type +toStringATS' :: QName a -> ErrM (ATS.Type b) toStringATS' (QNamed _ _ s) = Named . Unqualified <$> stringTypeConv s toStringATS' _ = unsupported "toStringATS'" -tyVarToSort :: TyVarBind a -> ErrM Universal +tyVarToSort :: TyVarBind a -> ErrM (Universal b) tyVarToSort (UnkindedVar _ (Ident _ s)) = Right $ Universal [s] (Just (Vt0p None)) mempty tyVarToSort _ = unsupported "tyVarToSort" -universalHelper :: [TyVarBind a] -> ErrM (ATS.Type -> ATS.Type) +universalHelper :: [TyVarBind a] -> ErrM (ATS.Type b -> ATS.Type b) universalHelper (t:ts) = fmap <$> (ForA <$> tyVarToSort t) <*> universalHelper ts universalHelper [] = pure id --- TODO track staloads? -typeToType :: HS.Type a -> ErrM ATS.Type +typeToType :: HS.Type a -> ErrM (ATS.Type b) typeToType (TyForall _ (Just us) Nothing t) = universalHelper us <*> typeToType t typeToType (TyCon _ qn) = toStringATS' qn typeToType (TyVar _ n) = Right $ Named $ Unqualified (toStringATS n) @@ -95,11 +93,11 @@ typeToType (TyTuple _ _ ts) = ATS.Tuple undefined <$> mapM typeToType ts typeToType _ = Left $ Unsupported "typeToType" -fieldDeclToType :: FieldDecl a -> ErrM (String, ATS.Type) +fieldDeclToType :: FieldDecl a -> ErrM (String, ATS.Type b) fieldDeclToType (FieldDecl _ [n] t) = (,) (toStringATS n) <$> typeToType t fieldDeclToType _ = Left $ Unsupported "fieldDeclToType" -conDeclToType :: ConDecl a -> ErrM (String, Maybe ATS.Type) +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 <$> mapM typeToType ts @@ -110,7 +108,7 @@ toStringATS (Ident _ s) = s toStringATS _ = undefined -tyvarToArg :: Bool -> TyVarBind a -> ErrM SortArg +tyvarToArg :: Bool -> TyVarBind a -> ErrM (SortArg b) tyvarToArg False (UnkindedVar _ n) = Right $ SortArg (toStringATS n) (Vt0p None) tyvarToArg True (UnkindedVar _ n) = Right $ SortArg (toStringATS n) (Vt0p Plus) tyvarToArg _ _ = unsupported "tyvarToArg" @@ -118,26 +116,26 @@ consM :: (Monad m) => m a -> m [a] -> m [a] consM x xs = (:) <$> x <*> xs -asATSName :: DeclHead a -> ErrM (String, [SortArg]) +asATSName :: DeclHead a -> ErrM (String, [SortArg b]) asATSName (DHead _ n) = Right (convertConventions $ toStringATS n, []) asATSName (DHParen _ d) = (,) . fst <$> asATSName d <*> pure [] asATSName (DHApp _ d tb) = (,) . fst <$> asATSName d <*> consM (tyvarToArg False tb) (snd <$> asATSName d) asATSName _ = unsupported "asATSName" -qualConDeclToType :: QualConDecl a -> ErrM ATS.Type +qualConDeclToType :: QualConDecl a -> ErrM (ATS.Type b) qualConDeclToType (EmptyQualCon _ cd) = fromJust . snd <$> conDeclToType cd qualConDeclToType _ = unsupported "qualConDeclToType" -qualConDeclToLeaf :: QualConDecl a -> ErrM Leaf +qualConDeclToLeaf :: QualConDecl a -> ErrM (Leaf b) qualConDeclToLeaf (EmptyQualCon _ cd) = Leaf [] <$> (over _head toUpper . convertConventions . fst <$> conDeclToType cd) <*> pure [] <*> (snd <$> conDeclToType cd) qualConDeclToLeaf _ = unsupported "qualConDeclToLeaf" -pruneATSNils :: [SortArg] -> Maybe [SortArg] +pruneATSNils :: [SortArg a] -> Maybe [SortArg a] pruneATSNils [] = Nothing pruneATSNils x = Just x -- TODO if it derives functor, use + -asATSType :: Decl a -> ErrM Declaration +asATSType :: Decl a -> ErrM (Declaration b) asATSType (TypeDecl _ dh t) = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (pruneATSNils . snd <$> asATSName dh) <*> typeToType t 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 @@ -156,12 +154,14 @@ modulePrint :: Module a -> (String, [GenerateError]) modulePrint = g . fmap asATSType . filterModule - where g = (printATS . ATS . reverse . rights) &&& lefts + where g = (h . ATS . reverse . rights) &&& lefts + h :: ATS AlexPosn -> String + h = printATS extends :: ParseMode -extends = defaultParseMode - { extensions = EnableExtension <$> es - , fixities = Just baseFixities } +extends = + defaultParseMode { extensions = EnableExtension <$> es, fixities = Just baseFixities } + where es = [ StandaloneDeriving , CPP , RecordWildCards