diff --git a/cabal.project.local b/cabal.project.local deleted file mode 100644 --- a/cabal.project.local +++ /dev/null @@ -1,7 +0,0 @@ -constraints: hs2ats +development -with-compiler: ghc-8.2.2 -tests: True -benchmarks: True -documentation: True -haddock-hoogle: True -haddock-internal: True diff --git a/hs2ats.cabal b/hs2ats.cabal --- a/hs2ats.cabal +++ b/hs2ats.cabal @@ -1,5 +1,5 @@ name: hs2ats -version: 0.1.0.1 +version: 0.2.0.0 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 @@ -11,8 +11,6 @@ category: Language, Haskell, ATS build-type: Simple extra-doc-files: README.md -extra-source-files: stack.yaml - , cabal.project.local cabal-version: 1.18 Flag development { @@ -24,6 +22,7 @@ library hs-source-dirs: src exposed-modules: Language.ATS.Generate + , Language.ATS.Generate.Error build-depends: base >= 4.7 && < 5 , haskell-src-exts , language-ats @@ -31,6 +30,9 @@ , cases , lens , optparse-generic + , ansi-wl-pprint + , composition-prelude + , deepseq default-language: Haskell2010 if flag(development) ghc-options: -Werror 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 @@ -8,14 +8,19 @@ module Language.ATS.Generate ( exec , generateATS + , genATSTypes + , ErrM ) where import Cases (snakify) +import Control.Arrow import Control.Lens (over, _head) import Data.Char (toUpper) +import Data.Either (lefts, rights) import Data.Maybe (fromJust) import qualified Data.Text as T import Language.ATS as ATS +import Language.ATS.Generate.Error import Language.Haskell.Exts.Parser import Language.Haskell.Exts.Syntax as HS import Options.Generic @@ -33,73 +38,77 @@ pattern EmptyQualCon :: l -> ConDecl l -> QualConDecl l pattern EmptyQualCon x cd = QualConDecl x Nothing Nothing cd -qnameToString :: QName a -> String -qnameToString (QNamed _ _ s) = convertConventions s -qnameToString _ = undefined +qnameToString :: QName a -> ErrM String +qnameToString (QNamed _ _ s) = Right $ convertConventions s +qnameToString _ = unsupported "qnameToString" -toStringATS' :: QName a -> ATS.Type -toStringATS' (QNamed _ _ "Int") = ATS.Int -toStringATS' (QNamed _ _ "Float") = ATS.Float -toStringATS' (QNamed _ _ "Integer") = Named (Unqualified "Intinf") -toStringATS' (QNamed _ _ "String") = Named (Unqualified "Strptr1") -- TODO string? -toStringATS' (QNamed _ _ "Bool") = ATS.Bool -toStringATS' (QNamed _ _ "Word") = Named (Unqualified "uint") -toStringATS' (QNamed _ _ "Double") = ATS.Double -toStringATS' _ = undefined +toStringATS' :: QName a -> ErrM ATS.Type +toStringATS' (QNamed _ _ "Int") = Right ATS.Int +toStringATS' (QNamed _ _ "Float") = Right ATS.Float +toStringATS' (QNamed _ _ "Integer") = Right $ Named (Unqualified "Intinf") +toStringATS' (QNamed _ _ "String") = Right $ Named (Unqualified "Strptr1") -- TODO string? +toStringATS' (QNamed _ _ "Bool") = Right ATS.Bool +toStringATS' (QNamed _ _ "Word") = Right $ Named (Unqualified "uint") +toStringATS' (QNamed _ _ "Double") = Right ATS.Double +toStringATS' _ = unsupported "toStringATS'" --- TODO warn on un-banged types --- TODO built-in constructors (particularly lists) -typeToType :: HS.Type a -> ATS.Type +typeToType :: HS.Type a -> ErrM ATS.Type typeToType (TyCon _ qn) = toStringATS' qn -typeToType (TyVar _ n) = Named $ Unqualified (toStringATS n) -typeToType (TyApp _ (TyCon _ qn) t'@TyCon{}) = Dependent (Unqualified $ qnameToString qn) [typeToType t'] -typeToType (TyApp _ t@TyApp{} t'@TyCon{}) = over typeCallArgs (typeToType t':) $ typeToType t +typeToType (TyVar _ n) = Right $ Named $ Unqualified (toStringATS n) +typeToType (TyApp _ (TyCon _ qn) t'@TyCon{}) = Dependent <$> (Unqualified <$> qnameToString qn) <*> (pure <$> typeToType t') +typeToType (TyApp _ t@TyApp{} t'@TyCon{}) = over typeCallArgs <$> fmap (:) (typeToType t') <*> typeToType t typeToType (TyParen _ t) = typeToType t typeToType (TyBang _ _ _ t) = typeToType t -typeToType (TyList _ t) = Dependent (Unqualified "List_vt") [typeToType t] -typeToType _ = undefined +typeToType (TyList _ t) = Dependent (Unqualified "List_vt") <$> (pure <$> typeToType t) +typeToType _ = Left $ Unsupported "typeToType" --- TODO allow multiple -fieldDeclToType :: FieldDecl a -> (String, ATS.Type) -fieldDeclToType (FieldDecl _ [n] t) = (toStringATS n, typeToType t) -fieldDeclToType _ = undefined +fieldDeclToType :: FieldDecl a -> ErrM (String, ATS.Type) +fieldDeclToType (FieldDecl _ [n] t) = (,) (toStringATS n) <$> typeToType t +fieldDeclToType _ = Left $ Unsupported "fieldDeclToType" -conDeclToType :: ConDecl a -> (String, Maybe ATS.Type) -conDeclToType (ConDecl _ n []) = (toStringATS n, Nothing) -conDeclToType (ConDecl _ n [t]) = (toStringATS n, Just $ typeToType t) -conDeclToType (RecDecl _ n fs) = (toStringATS n, Just $ AnonymousRecord undefined (fieldDeclToType <$> reverse fs)) -conDeclToType _ = undefined +conDeclToType :: ConDecl a -> ErrM (String, Maybe ATS.Type) +conDeclToType (ConDecl _ n []) = Right (toStringATS n, Nothing) +conDeclToType (ConDecl _ n [t]) = (,) (toStringATS n) . Just <$> typeToType t +conDeclToType (RecDecl _ n fs) = (,) (toStringATS n) . Just . AnonymousRecord undefined <$> mapM fieldDeclToType (reverse fs) +conDeclToType _ = unsupported "conDeclToType" toStringATS :: HS.Name a -> String toStringATS (Ident _ s) = s toStringATS _ = undefined -tyvarToArg :: TyVarBind a -> Arg -tyvarToArg (UnkindedVar _ n) = Arg (Both (toStringATS n) (Vt0p Plus)) -tyvarToArg _ = undefined +tyvarToArg :: Bool -> TyVarBind a -> ErrM Arg +tyvarToArg False (UnkindedVar _ n) = Right $ Arg (Both (toStringATS n) (Vt0p None)) +tyvarToArg True (UnkindedVar _ n) = Right $ Arg (Both (toStringATS n) (Vt0p Plus)) +tyvarToArg _ _ = unsupported "tyvarToArg" -asATSName :: DeclHead a -> (String, [Arg]) -asATSName (DHead _ n) = (convertConventions $ toStringATS n, []) -asATSName (DHParen _ d) = (fst $ asATSName d, []) -asATSName (DHApp _ d tb) = (fst $ asATSName d, tyvarToArg tb : snd (asATSName d)) -asATSName _ = undefined +consM :: (Monad m) => m a -> m [a] -> m [a] +consM x xs = (:) <$> x <*> xs -qualConDeclToType :: QualConDecl a -> ATS.Type -qualConDeclToType (EmptyQualCon _ cd) = fromJust $ snd $ conDeclToType cd -qualConDeclToType _ = undefined +asATSName :: DeclHead a -> ErrM (String, [Arg]) +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" -qualConDeclToLeaf :: QualConDecl a -> Leaf -qualConDeclToLeaf (EmptyQualCon _ cd) = Leaf [] (over _head toUpper $ convertConventions $ fst $ conDeclToType cd) [] (snd $ conDeclToType cd) -qualConDeclToLeaf _ = undefined +qualConDeclToType :: QualConDecl a -> ErrM ATS.Type +qualConDeclToType (EmptyQualCon _ cd) = fromJust . snd <$> conDeclToType cd +qualConDeclToType _ = unsupported "qualConDeclToType" -asATSType :: Decl a -> Declaration -asATSType (DataDecl _ NewType{} _ dh [qcd] _) = ViewTypeDef undefined (fst $ asATSName dh) (snd $ asATSName dh) (qualConDeclToType qcd) -asATSType (DataDecl _ DataType{} _ dh [qcd] _) = ViewTypeDef undefined (fst $ asATSName dh) (snd $ asATSName dh) (qualConDeclToType qcd) -asATSType (DataDecl _ DataType{} _ dh qcds _) = SumViewType (fst $ asATSName dh) (snd $ asATSName dh) (qualConDeclToLeaf <$> reverse qcds) -asATSType _ = undefined +qualConDeclToLeaf :: QualConDecl a -> ErrM Leaf +qualConDeclToLeaf (EmptyQualCon _ cd) = Leaf [] <$> (over _head toUpper . convertConventions . fst <$> conDeclToType cd) <*> pure [] <*> (snd <$> conDeclToType cd) +qualConDeclToLeaf _ = unsupported "qualConDeclToLeaf" +-- TODO if it derives functor, use + +asATSType :: Decl a -> ErrM Declaration +asATSType (TypeDecl _ dh t) = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (snd <$> asATSName dh) <*> typeToType t +asATSType (DataDecl _ NewType{} _ dh [qcd] _) = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (snd <$> asATSName dh) <*> qualConDeclToType qcd +asATSType (DataDecl _ DataType{} _ dh [qcd] _) = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (snd <$> asATSName dh) <*> qualConDeclToType qcd +asATSType (DataDecl _ DataType{} _ dh qcds _) = SumViewType <$> (fst <$> asATSName dh) <*> (snd <$> asATSName dh) <*> mapM qualConDeclToLeaf (reverse qcds) +asATSType _ = unsupported "asATSType" + -- TODO GDataDecl and DataFamDecl isDataDecl :: Decl a -> Bool +isDataDecl TypeDecl{} = True isDataDecl DataDecl{} = True isDataDecl _ = False @@ -110,20 +119,24 @@ -- #include "contrib/atscntrb-hx-intinf/mylibies.hats" -modulePrint :: Module a -> String -modulePrint = printATS . ATS . reverse . fmap asATSType . filterModule +-- TODO @rights@ for stuff. -generateATS :: String -> String -generateATS hsSrc = modulePrint $ case parseModule hsSrc of - ParseOk x -> x - ParseFailed loc msg -> error (show loc ++ "\n" ++ msg) +modulePrint :: Module a -> (String, [GenerateError]) +modulePrint = g . fmap asATSType . filterModule + where g = (printATS . ATS . reverse . rights) &&& lefts -withFile :: FilePath -> FilePath -> IO () -withFile p p' = do +generateATS :: String -> ErrM (String, [GenerateError]) +generateATS hsSrc = modulePrint <$> case parseModule hsSrc of + ParseOk x -> Right x + ParseFailed loc msg -> syntaxError loc msg + +genATSTypes :: FilePath -> FilePath -> IO () +genATSTypes p p' = do contents <- readFile p - writeFile p' (generateATS contents) + let warnDo (x, es) = mapM_ displayErr es >> writeFile p' x + either displayErr warnDo (generateATS contents) exec :: IO () exec = do x <- getRecord "Generate ATS types for Haskell source code" :: IO Program - withFile (unHelpful . src $ x) (unHelpful . target $ x) + genATSTypes (unHelpful . src $ x) (unHelpful . target $ x) diff --git a/src/Language/ATS/Generate/Error.hs b/src/Language/ATS/Generate/Error.hs new file mode 100644 --- /dev/null +++ b/src/Language/ATS/Generate/Error.hs @@ -0,0 +1,45 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Language.ATS.Generate.Error ( -- * Types + GenerateError (..) + , ErrM + -- * Functions + , displayErr + -- * Helper functions + , unsupported + , syntaxError + ) where + +import Control.Composition +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) +import Language.Haskell.Exts hiding (Pretty, loc) +import System.IO (stderr) +import Text.PrettyPrint.ANSI.Leijen + +deriving instance NFData SrcLoc + +displayErr :: GenerateError -> IO () +displayErr = hPutDoc stderr . pretty + +type ErrM a = Either GenerateError a + +syntaxError :: SrcLoc -> String -> ErrM a +syntaxError = Left .* HaskellSyntaxError + +unsupported :: String -> ErrM a +unsupported = Left . Unsupported + +data GenerateError = Unsupported String + | HaskellSyntaxError SrcLoc String + | Internal 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) = red "Error:" <+> "failed to parse" <+> text (show loc) <> colon <$$> indent 2 (text s) <> linebreak + pretty (Internal s) = red "Error:" <+> "internal error: " <$$> indent 2 (text s) <> linebreak diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 --- a/stack.yaml +++ /dev/null @@ -1,9 +0,0 @@ ---- -resolver: lts-10.4 -packages: - - '.' -extra-deps: [] -flags: - hs2ats: - development: false -extra-package-dbs: [] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -13,4 +13,4 @@ main :: IO () main = hspec $ describe "generateATS" $ parallel $ - testFiles "test/data" isATS ((pure :: a -> Either String a) . generateATS) + testFiles "test/data" isATS (fmap fst . generateATS)