hs2ats 0.1.0.1 → 0.2.0.0

raw patch · 6 files changed

+122/−78 lines, 6 filesdep +ansi-wl-pprintdep +composition-preludedep +deepseqdep ~language-atsPVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-wl-pprint, composition-prelude, deepseq

Dependency ranges changed: language-ats

API changes (from Hackage documentation)

Files

• cabal.project.local +0/−7
• hs2ats.cabal +5/−3
• src/Language/ATS/Generate.hs +71/−58
• src/Language/ATS/Generate/Error.hs +45/−0
• stack.yaml +0/−9
• test/Spec.hs +1/−1

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -1,9 +0,0 @@-----resolver: lts-10.4-packages:-  - '.'-extra-deps: []-flags:-  hs2ats:-    development: false-extra-package-dbs: []

@@ -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)