hs2ats 0.2.1.3 → 0.2.1.4

raw patch · 4 files changed

+52/−27 lines, 4 filesdep +cpphsdep ~language-atsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: cpphs

Dependency ranges changed: language-ats

API changes (from Hackage documentation)

Files

• bench/Bench.hs +2/−2
• hs2ats.cabal +2/−2
• src/Language/ATS/Generate.hs +47/−22
• test/Spec.hs +1/−1

@@ -7,6 +7,6 @@ main =     defaultMain [ env file $ \f ->                   bgroup "generateATS"-                      [ bench "test/data/SumType.hs" $ nf generateATS f ]+                      [ bench "test/data/HigherOrder.hs" $ nf generateATS f ]                 ]-    where file = readFile "test/data/SumType.hs"+    where file = readFile "test/data/HigherOrder.hs"

@@ -1,5 +1,5 @@ name:                hs2ats-version:             0.2.1.3+version:             0.2.1.4 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@@ -33,6 +33,7 @@                      , ansi-wl-pprint                      , composition-prelude                      , deepseq+                     , cpphs   default-language:    Haskell2010   if flag(development)     ghc-options:       -Werror@@ -62,7 +63,6 @@                      , hspec                      , hspec-dirstream                      , system-filepath-                     , language-ats   if flag(development)     ghc-options:       -Werror   if impl(ghc >= 8.0)

@@ -15,6 +15,7 @@ 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@@ -23,14 +24,16 @@ 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  data Program = Program { src    :: FilePath <?> "Haskell source file"                        , target :: FilePath <?> "ATS target"+                       , cpphs  :: Bool <?> "Use cpphs as a preprocessor"                        } deriving (Generic, ParseRecord)  convertConventions :: String -> String-convertConventions = T.unpack . snakify . T.pack+convertConventions = filterKeys . T.unpack . snakify . T.pack  pattern QNamed :: l -> l -> String -> QName l pattern QNamed x y s = UnQual x (Ident y s)@@ -41,12 +44,17 @@ pattern EmptyQualCon :: l -> ConDecl l -> QualConDecl l pattern EmptyQualCon x cd = QualConDecl x Nothing Nothing cd +filterKeys :: String -> String+filterKeys "var" = "var_"+filterKeys s     = s+ qnameToString :: QName a -> ErrM String-qnameToString (QNamed _ _ s) = Right $ convertConventions s-qnameToString _              = unsupported "qnameToString"+qnameToString (QNamed _ _ "Maybe") = Right "Option_vt"+qnameToString (QNamed _ _ s)       = Right $ convertConventions s+qnameToString _                    = unsupported "qnameToString" +-- should we allow user-defined string map? stringTypeConv :: String -> ErrM String-stringTypeConv "Maybe"   = Right "Option_vt" stringTypeConv "Integer" = Right "Intinf" stringTypeConv "String"  = Right "Strptr1" stringTypeConv "CString" = Right "Strptr1"@@ -65,15 +73,26 @@ toStringATS' (QNamed _ _ s) = Named . Unqualified <$> stringTypeConv s toStringATS' _              = unsupported "toStringATS'" +tyVarToSort :: TyVarBind a -> ErrM Universal+tyVarToSort (UnkindedVar _ (Ident _ s)) = Right $ Universal [s] (Just (Vt0p None)) mempty+tyVarToSort _                           = unsupported "tyVarToSort"++universalHelper :: [TyVarBind a] -> ErrM (ATS.Type -> ATS.Type)+universalHelper (t:ts) = fmap <$> (ForA <$> tyVarToSort t) <*> universalHelper ts+universalHelper []     = pure id++-- TODO track staloads? typeToType :: HS.Type a -> ErrM ATS.Type+typeToType (TyForall _ (Just us) Nothing t)   = universalHelper us <*> typeToType t typeToType (TyCon _ qn)                       = toStringATS' qn typeToType (TyVar _ n)                        = Right $ Named $ Unqualified (toStringATS n) typeToType (TyApp _ (TyCon _ QStorable{}) t') = typeToType t'-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 (TyApp _ (TyCon _ qn) t')          = Dependent <$> (Unqualified <$> qnameToString qn) <*> (pure <$> typeToType t')+typeToType (TyApp _ t@TyApp{} t')             = over typeCallArgs <$> fmap (:) (typeToType t') <*> typeToType t typeToType (TyParen _ t)                      = typeToType t typeToType (TyBang _ _ _ t)                   = typeToType t-typeToType (TyList _ t)                       = Dependent (Unqualified "List_vt") <$> (pure <$> typeToType t)+typeToType (TyFun _ t t')                     = FunctionType "-<lincloptr1>" <$> typeToType t <*> typeToType t'+typeToType (TyTuple _ _ ts)                   = ATS.Tuple undefined <$> mapM typeToType ts typeToType _                                  = Left $ Unsupported "typeToType"  fieldDeclToType :: FieldDecl a -> ErrM (String, ATS.Type)@@ -83,6 +102,7 @@ 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 (ConDecl _ n ts)  = (,) (toStringATS n) . Just . ATS.Tuple undefined <$> mapM typeToType ts conDeclToType (RecDecl _ n fs)  = (,) (toStringATS n) . Just . AnonymousRecord undefined <$> mapM fieldDeclToType (reverse fs) conDeclToType _                 = unsupported "conDeclToType" @@ -124,44 +144,49 @@ asATSType (DataDecl _ DataType{} _ dh qcds _)  = SumViewType <$> (fst <$> asATSName dh) <*> (pruneATSNils . snd <$> asATSName dh) <*> mapM qualConDeclToLeaf (reverse qcds) asATSType _                                    = unsupported "asATSType" --- TODO GDataDecl and DataFamDecl+-- TODO GDataDecl isDataDecl :: Decl a -> Bool isDataDecl TypeDecl{} = True isDataDecl DataDecl{} = True isDataDecl _          = False --- TODO imports filterModule :: Module a -> [Decl a] filterModule (Module _ _ _ _ ds) = filter isDataDecl ds filterModule _                   = [] --- #include "contrib/atscntrb-hx-intinf/mylibies.hats"---- TODO @rights@ for stuff.- modulePrint :: Module a -> (String, [GenerateError]) modulePrint = g . fmap asATSType . filterModule     where g = (printATS . ATS . reverse . rights) &&& lefts  extends :: ParseMode extends = defaultParseMode-    { extensions = [EnableExtension StandaloneDeriving]+    { extensions = EnableExtension <$> es     , fixities = Just baseFixities }+    where es = [ StandaloneDeriving+               , CPP+               , RecordWildCards+               , BangPatterns+               , ExplicitForAll+               ]  -- | Given a string containing Haskell, return a string containing ATS and -- a list of warnings.-generateATS :: String -> ErrM (String, [GenerateError])-generateATS hsSrc = modulePrint <$> case parseModuleWithMode extends hsSrc of+generateATS :: FilePath -> String -> ErrM (String, [GenerateError])+generateATS file hsSrc = modulePrint <$> case parseModuleWithMode extends hsSrc of     ParseOk x            -> Right x-    ParseFailed loc' msg -> syntaxError loc' msg+    ParseFailed loc' msg -> syntaxError (loc' { srcFilename = file }) msg -genATSTypes :: FilePath -> FilePath -> IO ()-genATSTypes p p' = do-    contents <- readFile p+process :: FilePath -> String -> IO String+process p = fmap (unlines . drop 1 . lines) . runCpphs defaultCpphsOptions p++genATSTypes :: FilePath -> FilePath -> Bool -> IO ()+genATSTypes p p' withCPP = do+    let proc = bool pure (process p) withCPP+    contents <- proc =<< readFile p     let warnDo (x, es) = mapM_ displayErr es >> writeFile p' x-    either displayErr warnDo (generateATS contents)+    either displayErr warnDo (generateATS p contents)  exec :: IO () exec = do     x <- getRecord "Generate ATS types for Haskell source code" :: IO Program-    genATSTypes (unHelpful . src $ x) (unHelpful . target $ x)+    genATSTypes (unHelpful . src $ x) (unHelpful . target $ x) (unHelpful . cpphs $ x)

@@ -13,4 +13,4 @@ main :: IO () main = hspec $     describe "generateATS" $ parallel $-        testFiles "test/data" isATS (fmap fst . generateATS)+        testFiles "test/data" isATS (fmap fst . generateATS "<unknown>")