diff --git a/modulo.cabal b/modulo.cabal --- a/modulo.cabal +++ b/modulo.cabal @@ -1,6 +1,6 @@ name: modulo -version: 1.5 +version: 1.7.2 cabal-version: >= 1.6 author: Hans Hoglund maintainer: Hans Hoglund @@ -32,7 +32,12 @@ prettify >= 1.0 && < 2, language-c, haskell-src == 1.0.1.5, - atto-lisp + atto-lisp, + + pandoc-types == 1.10, + pandoc == 1.11.1, + process, + directory hs-source-dirs: src exposed-modules: Language.Modulo @@ -41,6 +46,7 @@ Language.Modulo.Lisp Language.Modulo.Haskell Language.Modulo.JavaScript + Language.Modulo.Pandoc Language.Modulo.Load Language.Modulo.Parse diff --git a/src/Language/Modulo.hs b/src/Language/Modulo.hs --- a/src/Language/Modulo.hs +++ b/src/Language/Modulo.hs @@ -128,6 +128,9 @@ data Module = Module { + -- TODO properties: + -- transient :: Bool (ignore last component in name for mangling) + -- visibility :: Public | Internal modDoc :: Doc, modName :: ModuleName, -- ^ Name of module modImports :: [(ModuleName, Maybe String)], -- ^ Imports with optional import conventions @@ -237,7 +240,7 @@ -- | A function type. data FunType - = Function [Type] Type -- ^ The C function type @Tn(T1, ... Tn-1)@. + = Function [(Maybe Name, Type)] Type -- ^ The C function type @Tn(T1, ... Tn-1)@. deriving (Eq, Show) data CompType diff --git a/src/Language/Modulo/C.hs b/src/Language/Modulo/C.hs --- a/src/Language/Modulo/C.hs +++ b/src/Language/Modulo/C.hs @@ -22,8 +22,8 @@ stdStyle, cairoStyle, gtkStyle, - -- appleStyle, - -- haskellStyle, + appleStyle, + haskellStyle, -- ** Conversion translType, @@ -44,7 +44,9 @@ ) where import Data.Default +import Data.Foldable (toList) import Data.Semigroup +import Control.Arrow import Language.Modulo import Language.Modulo.Util @@ -83,8 +85,8 @@ includeStyle :: ImportStyle, -- ^ How to write import declarations includeDirective :: String, -- ^ Import directive, usually @include@. guardMangler :: [String] -> String, -- ^ Mangler for names of header guards - innerHeader :: [String] -> String -> String, -- ^ Inner header mangler (components moduleDoc) - innerFooter :: [String] -> String, -- ^ Inner footer mangler + innerHeader :: [String] -> String -> String, -- ^ Inner header mangler (receives module name, documentation) + innerFooter :: [String] -> String, -- ^ Inner footer mangler (receives module name) -- Prefix typePrefixMangler :: [String] -> String, -- ^ Prefix for types @@ -452,12 +454,14 @@ flattenModule :: CStyle -> Module -> Module flattenModule st (Module doc n is ds) = Module doc n is (map (fmap $ flattenDecl st) ds) +flattenDecl :: CStyle -> Decl -> Decl flattenDecl st (TypeDecl n t) = TypeDecl (translType st n) (fmap (flattenType st) t) flattenDecl st (FunctionDecl n t) = FunctionDecl (translFun st n) (flattenFunType st t) flattenDecl st (TagDecl t) = TagDecl (flattenType st t) flattenDecl st (ConstDecl n v t) = ConstDecl (translConst st n) v (flattenType st t) flattenDecl st (GlobalDecl n v t) = GlobalDecl (translGlobal st n) v (flattenType st t) +flattenType :: CStyle -> Type -> Type flattenType st (PrimType t) = PrimType t flattenType st (AliasType n) = AliasType $ flattenAlias st n flattenType st (RefType t) = RefType $ flattenRefType st t @@ -472,7 +476,7 @@ flattenRefType st (Array t n) = Array (flattenType st t) n flattenFunType :: CStyle -> FunType -> FunType -flattenFunType st (Function as r) = Function (fmap (flattenType st) as) (flattenType st r) +flattenFunType st (Function as r) = Function (fmap (second $ flattenType st) as) (flattenType st r) flattenCompType :: CStyle -> CompType -> CompType flattenCompType st (Enum ns) = Enum $ fmap (translEnumField st) ns @@ -655,7 +659,8 @@ where (typ, decls) = convertType st r args :: [CDecl] - args = map (\t -> declParam st Nothing t) as + args = map (\(n,t) -> declParam st n t) $ as + -- TODO #34 use name convertCompType :: CStyle -> CompType -> ([CTypeSpec], [CDerivedDeclr]) convertCompType st (Enum as) = ([typ], []) diff --git a/src/Language/Modulo/Haskell.hs b/src/Language/Modulo/Haskell.hs --- a/src/Language/Modulo/Haskell.hs +++ b/src/Language/Modulo/Haskell.hs @@ -35,6 +35,7 @@ ) where import Data.Default +import Data.Foldable (toList) import Data.Semigroup import Data.Char (chr) import Data.Text (pack) @@ -100,31 +101,56 @@ convertTopLevel :: HaskellStyle -> Module -> HsModule convertTopLevel st (Module doc n is ds) = - HsModule def (convertModule n) Nothing [] $ fmap (convertDecl st . snd) ds + -- TODO docs + -- TODO nice export spec (excluding opaque struct types etc) + HsModule def (convertModule n) Nothing imps decls + where + imps = standardForeignImports ++ concatMap (uncurry convertImport) is + decls = concatMap (convertDecl st . snd) ds -convertDecl :: HaskellStyle -> Decl -> HsDecl +convertImport :: ModuleName -> Maybe String -> [HsImportDecl] +convertImport _ (Just "C") = [] -- Skip C imports +convertImport n _ = [HsImportDecl def (convertModule n) False Nothing Nothing] + +standardForeignImports = [ + HsImportDecl def (Hs.Module "Foreign") False Nothing Nothing, + HsImportDecl def (Hs.Module "Foreign.C") False Nothing Nothing] + +convertDecl :: HaskellStyle -> Decl -> [HsDecl] convertDecl st (TypeDecl n Nothing) = declOpaque st n -convertDecl st (TypeDecl n (Just t)) = declType st n t -- typedef T N; -convertDecl st (FunctionDecl n t) = declFun st n t -- T n (as); -convertDecl st (TagDecl t) = notSupported "Tag decls" -- T; -convertDecl st (ConstDecl n v t) = notSupported "Constants" -- T n; or T n = v; -convertDecl st (GlobalDecl n v t) = notSupported "Globals" -- T n; or T n = v; +-- Uses return here as only opaque needs to emit an extra declaration +-- We might change the types of declType, declFun etc instead +convertDecl st (TypeDecl n (Just t)) = return $ declType st n t -- typedef T N; +convertDecl st (FunctionDecl n t) = return $ declFun st n t -- T n (as); +convertDecl st (TagDecl t) = return $ notSupported "Tag decls" -- T; +convertDecl st (ConstDecl n v t) = return $ notSupported "Constants" -- T n; or T n = v; +convertDecl st (GlobalDecl n v t) = return $ notSupported "Globals" -- T n; or T n = v; -declOpaque :: HaskellStyle -> Name -> HsDecl -declOpaque st (Name n) = HsDataDecl def [] (HsIdent n) [] [] [] -declOpaque st (QName _ n) = HsDataDecl def [] (HsIdent n) [] [] [] +declOpaque :: HaskellStyle -> Name -> [HsDecl] +declOpaque st (Name n) = error "Expected qualified name" +declOpaque st (QName _ n) = [HsDataDecl def [] (HsIdent $ n ++ "_") [] [] [], + HsTypeDecl def (HsIdent $ n) [] $ + HsTyCon (UnQual "Ptr") `HsTyApp` HsTyCon (UnQual (HsIdent $ n ++ "_"))] declType :: HaskellStyle -> Name -> Type -> HsDecl -declType st n t = HsTypeDecl def (HsIdent $ getName n) [] (convertType st t) +declType st n t = HsTypeDecl def (HsIdent $ getNameEnd n) [] (convertType st t) +-- TODO check purity properties and add IO if needed declFun :: HaskellStyle -> Name -> FunType -> HsDecl -declFun st n t = HsForeignImport def "ccall" HsUnsafe cName hsName hsType +declFun st n t = HsForeignImport def "ccall" HsUnsafe cName hsName (addIO hsType) where - cName = getName (translFun (cStyle st) n) - hsName = HsIdent (getName n) + cName = getName (translFun (cStyle st) n) -- Always returns an unqualified name (TODO document in C module) + hsName = HsIdent $ getNameEnd n hsType = convertFunType st t +addIO (HsTyFun a b) = HsTyFun a (addIO b) +addIO b = HsTyApp (HsTyVar $ HsIdent "IO") b +-- TODO move +-- | Returns the last part of an unqualified name. +getNameEnd (QName _ x) = x +getNameEnd _ = error "Expected qualified name" + -- TODO partial on (CompType (Struct..)), (for struct, union and bitfield) convertType :: HaskellStyle -> Type -> HsType convertType st (AliasType n) = convertAlias st n @@ -134,8 +160,9 @@ convertType st (CompType t) = convertCompType st t convertAlias :: HaskellStyle -> Name -> HsType -convertAlias st (Name n) = HsTyCon $ (UnQual (HsIdent n)) -convertAlias st (QName m n) = HsTyCon $ (Qual (convertModule m) (HsIdent n)) +convertAlias st n = HsTyCon $ UnQual $ HsIdent $ getNameEnd n +-- convertAlias st (Name n) = HsTyCon $ (UnQual (HsIdent n)) +-- convertAlias st (QName m n) = HsTyCon $ (Qual (convertModule m) (HsIdent n)) convertPrimType :: HaskellStyle -> PrimType -> HsType convertPrimType st Bool = HsTyCon (UnQual "CInt") @@ -176,13 +203,14 @@ convertFunType st = go where go (Function [] r) = {-(HsTyCon (UnQual "IO")) `HsTyApp`-} convertType st r - go (Function (t:ts) r) = convertType st t `HsTyFun` convertFunType st (Function ts r) + go (Function ((_,t):ts) r) = convertType st t `HsTyFun` convertFunType st (Function ts r) + -- TODO #34 use param names convertCompType :: HaskellStyle -> CompType -> HsType convertCompType st (Enum as) = HsTyCon (UnQual "CInt") -convertCompType st (Struct as) = notSupported "Compound types with Haskell" -convertCompType st (Union as) = notSupported "Compound types with Haskell" -convertCompType st (BitField as) = notSupported "Compound types with Haskell" +convertCompType st (Struct as) = convertType st voidPtr +convertCompType st (Union as) = convertType st voidPtr +convertCompType st (BitField as) = notSupported "Haskell: bitfields" instance IsString HsName where fromString = HsIdent @@ -197,3 +225,6 @@ convertModule = Hs.Module . concatSep "." . getModuleNameList notSupported x = error $ "Not supported yet: " ++ x + +-- TODO move +voidPtr = RefType (Pointer $ PrimType Void) diff --git a/src/Language/Modulo/Lisp.hs b/src/Language/Modulo/Lisp.hs --- a/src/Language/Modulo/Lisp.hs +++ b/src/Language/Modulo/Lisp.hs @@ -22,10 +22,15 @@ printModuleLisp, renderModuleLisp, printModuleLispStyle, - renderModuleLispStyle + renderModuleLispStyle, + + -- ** Names + convertName, + convertType, ) where import Data.Default +import Data.Foldable (toList) import Data.Semigroup import Data.Char (chr) import Data.Text (pack) @@ -40,15 +45,19 @@ data LispStyle = LispStyle { - cStyle :: CStyle, -- ^ For generating foreign declarations - package :: String, -- ^ Package in which to generate definitions - safeOpaque :: Bool -- ^ If true, generate a wrapper class for each opaque type. + cStyle :: CStyle, -- ^ For generating foreign declarations + package :: String, -- ^ Package in which to generate definitions + prefixMangler :: [String] -> [String], -- ^ A mangler for prefixes. + safeOpaque :: Bool, -- ^ If true, generate a wrapper class for each opaque type. + primBoolType :: Maybe PrimType -- ^ Type of primitive booleans (default Int). } stdLispStyle = LispStyle { cStyle = stdStyle, package = "cl-user", - safeOpaque = True + prefixMangler = tail, + safeOpaque = True, + primBoolType = Nothing } -- | Default instance using 'stdStyle'. @@ -141,28 +150,29 @@ list [symbol "x", list [symbol "type", metaName]], list [symbol "make-instance", qualTypeName, keyword slot, symbol "x"]] - slot = withSuffix "-ptr" $ convertName n - qualMetaName = symbol $ withPrefix "'" $ withSuffix "-type" $ convertName n - metaName = symbol $ withSuffix "-type" $ convertName n - qualTypeName = symbol $ withPrefix "'" $ convertName n - typeName = symbol $ convertName n + slot = withSuffix "-ptr" $ convertName st n + qualMetaName = symbol $ withPrefix "'" $ withSuffix "-type" $ convertName st n + metaName = symbol $ withSuffix "-type" $ convertName st n + qualTypeName = symbol $ withPrefix "'" $ convertName st n + typeName = symbol $ convertName st n -- return $ list [symbol "defctype", symbolName n, keyword "pointer"] declType :: LispStyle -> Name -> Type -> [Lisp] -declType st n t = return $ list [symbol "defctype", symbolName n, convertType st t] +declType st n t = return $ list [symbol "defctype", symbolName st n, convertType st t] declFun :: LispStyle -> Name -> FunType -> [Lisp] declFun st n (Function as r) = return $ list $ [symbol "defcfun", list [name, cname], ret] ++ args where - name = symbolName n + name = symbolName st n ret = convertType st r cname = string $ convertCFunName (cStyle st) n argNames = map (symbol . return . chr) [97..(97+25)] - argTypes = map (convertType st) as + argTypes = map (\(_,t) -> convertType st t) $ as + -- TODO #34 use names args = map (\(n,t) -> list [n, t]) (zip argNames argTypes) @@ -174,10 +184,12 @@ convertType st (CompType t) = convertCompType st t convertAlias :: LispStyle -> Name -> Lisp -convertAlias st n = symbolName n +convertAlias st n = symbolName st n convertPrimType :: LispStyle -> PrimType -> Lisp -convertPrimType st Bool = keyword "boolean" +convertPrimType st Bool = case primBoolType st of + Nothing -> keyword "boolean" + Just primBoolType -> list [keyword "boolean", convertPrimType st primBoolType] convertPrimType st Void = keyword "void" convertPrimType st Char = keyword "char" convertPrimType st Short = keyword "short" @@ -211,7 +223,8 @@ convertRefType :: LispStyle -> RefType -> Lisp convertRefType st (Pointer t) = list [keyword "pointer", convertType st t] -convertRefType st (Array t n) = notSupported "Array types with Lisp" +convertRefType st (Array t n) = convertRefType st (Pointer t) +-- convertRefType st (Array t n) = notSupported "Array types with Lisp" -- TODO convertFunType :: LispStyle -> FunType -> Lisp @@ -239,23 +252,18 @@ keyword :: String -> Lisp keyword x = Symbol (pack $ ":" ++ x) -stringName :: Name -> Lisp -stringName = string . convertName {- getName-} - -symbolName :: Name -> Lisp -symbolName = symbol . convertName {- getName-} +stringName :: LispStyle -> Name -> Lisp +stringName st = string . convertName st {- getName-} -keywordName :: Name -> Lisp -keywordName = keyword . convertName {- getName-} +symbolName :: LispStyle -> Name -> Lisp +symbolName st = symbol . convertName st {- getName-} --- TODO there should be in the style -convertName :: Name -> String -convertName (Name n) = {-withPrefix "#" $ -} toLowerString $ concatSep "-" (unmangle n) -convertName (QName m n) = {-withPrefix "#" $ -} toLowerString $ concatSep "-" (stripPackage (getModuleNameList m) ++ unmangle n) +keywordName :: LispStyle -> Name -> Lisp +keywordName st = keyword . convertName st {- getName-} -stripPackage :: [String] -> [String] -stripPackage = tail --- TODO only strip prefix that matches (unmangle (package st)) +convertName :: LispStyle -> Name -> String +convertName st (Name n) = toLowerString $ concatSep "-" $ unmangle n +convertName st (QName m n) = toLowerString $ concatSep "-" $ (prefixMangler st) (getModuleNameList m) ++ unmangle n convertCTypeName :: CStyle -> Name -> String convertCTypeName st n = getName (translType st n) @@ -266,6 +274,7 @@ -- TODO type fun const global enumF structF unionF +-- TODO move voidPtr = RefType (Pointer $ PrimType Void) diff --git a/src/Language/Modulo/Pandoc.hs b/src/Language/Modulo/Pandoc.hs new file mode 100644 --- /dev/null +++ b/src/Language/Modulo/Pandoc.hs @@ -0,0 +1,216 @@ + +{-# LANGUAGE DisambiguateRecordFields, TypeFamilies, + StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- License : BSD-style +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : GHC +-- +-- Renders module descriptions (and documentation) as plain Pandoc. +-- +------------------------------------------------------------------------------------- + +module Language.Modulo.Pandoc ( + -- ** Styles + PandocStyle(..), + stdPandocStyle, + -- ** Rendering + -- printModulePandoc, + renderModulePandoc, + ) where + +import Data.Default +import Data.Semigroup +import Data.Char (chr) +import Data.Text (pack) + +import Language.Modulo.C +import Language.Modulo.Util +import Language.Modulo.Util.Unmangle +import Language.Modulo +import qualified Language.Modulo.C as C +import qualified Language.Modulo.Haskell as Haskell +import qualified Language.Modulo.Lisp as Lisp + +-- DEBUG +import Control.Monad +import System.Directory +import System.Process +import Text.Pandoc.Options +import Text.Pandoc.Templates +import Language.Modulo.Load +import Language.Modulo.Parse +import Language.Modulo.Rename +-- DEBUG + +import qualified Data.List as List +import Text.Pandoc.Definition +import Text.Pandoc.Writers.HTML +import Text.Pandoc.Writers.LaTeX +import Text.Pandoc.Readers.Markdown + +data PandocStyle = PandocStyle + deriving (Eq, Ord, Show) + +stdMeta = Meta [] [] [] +blockToPandoc = Pandoc stdMeta . return +blocksToPandoc = Pandoc stdMeta +mdStringToPandoc = readMarkdown def +instance Semigroup Pandoc where + (<>) = mappend +instance Monoid Pandoc where + mempty = Pandoc stdMeta mempty + Pandoc m1 bs1 `mappend` Pandoc m2 bs2 = Pandoc (m1 {-First-}) (bs1 <> bs2) + +stdPandocStyle = PandocStyle + +renderModulePandoc :: Module -> Pandoc +renderModulePandoc = renderModulePandocStyle stdPandocStyle + + +renderModulePandocStyle :: PandocStyle -> Module -> Pandoc +renderModulePandocStyle st mod = Pandoc stdMeta [ + Header 2 ("", [], [("id",show $ modName mod)]) [Str (show $ modName mod)] + -- CodeBlock nullAttr "import X.X.X", + -- CodeBlock nullAttr "foo : Ptr -> Ptr" + ] <> is <> ds + where + is = mconcat $ fmap (uncurry $ convertImport st) $ modImports mod + ds = mconcat $ fmap (uncurry $ convertDocDecl st) $ modDecls mod + +-- TODO link +convertImport :: PandocStyle -> ModuleName -> Maybe String -> Pandoc +convertImport st name conv = blockToPandoc $ CodeBlock nullAttr $ "import " ++ show name + +convertDocDecl :: PandocStyle -> Doc -> Decl -> Pandoc +convertDocDecl st doc decl = blocksToPandoc [ + CodeBlock css $ unname $ getDeclName decl + ] + <> + (mdStringToPandoc $ getDoc $ doc) + where + -- unname = maybe "" (show . C.translFun def) + -- unname = maybe "" getShortName + unname = if isTypeDecl decl + then ("(defclass " ++) . (++ " ())") . maybe "" (Lisp.convertName def) + else (\x -> "(defun " ++ x ++ " (" ++ List.intercalate " " (argNames decl) ++ "))") . maybe "" (Lisp.convertName def) + where + isTypeDecl (TypeDecl _ _) = True + isTypeDecl _ = False + + argNames (FunctionDecl _ ft) = argNames2 ft + argNames2 (Function as r) = fmap (showT.snd) as ++ [showT r] + showT = show . Lisp.convertType def + -- TODO #34 use name + + css = (".codeName", [], [("", "")]) + + getShortName (QName _ n) = n + + + + +-- allFilesMatching :: FilePath -> (FilePath -> Bool) -> IO [FilePath] + + + + + + + +main = documentFiles ["/Users/hans/audio/modules"] "/Users/hans/audio/modules" +-- main = documentFile ["/Users/hans/audio/modules"] "/Users/hans/audio/modules/Fa/Signal.module" + +document :: [ModulePath] -> String -> IO Pandoc +document mpaths str = do + mod <- unsafeRename mpaths . unsafeParse $ str + putStr $ "Documenting " ++ show (modName mod) ++ "\n" + return $ renderModulePandoc mod + +documentFiles :: [ModulePath] -> FilePath -> IO () +documentFiles mpaths path = do + paths <- listFilesMatching path (List.isSuffixOf ".module") + pandocs <- mapM (\path -> document mpaths =<< readFile path) paths + strs <- toHtmlStr $ mconcat pandocs + writeFile "test.html" $ strs + return () + where + cssBody = mempty + <> "body > pre { " + <> " padding: 20px; " + <> " margin-top: 15px; " + <> " margin-bottom: 15px; " + <> " background: #faffff; " + <> " border-radius: 12px; " + <> " border: 1px solid LightGrey; " + <> " box-shadow: 3px 3px 5px #eee; " + <> " overflow: auto; " + <> "}" + <> "" + <> "" + <> "" + <> "" + <> "" + <> "" + <> "" + <> "" + + toHtmlStr :: Pandoc -> IO String + toHtmlStr str = do + Right templ <- getDefaultTemplate Nothing "html" + return $ flip writeHtmlString str $ def { + writerTemplate = templ, + writerStandalone = True, + writerTableOfContents = True, + writerVariables = [("highlighting-css", cssBody)] } + +documentFile :: [ModulePath] -> FilePath -> IO () +documentFile mpaths path = do + pd <- document mpaths =<< readFile path + writeFile "test.html" $ writeHtmlString def pd + + + + +unsafeRename :: [ModulePath] -> Module -> IO Module +unsafeRename paths m = do + deps <- loadDependencies (withStdModulePaths paths) m + return $ rename deps m + +unsafeParse :: String -> Module +unsafeParse s = case (parse s) of + Left e -> error $ "Parse error: " ++ show e + Right m -> m + + +listFilesMatching :: FilePath -> (FilePath -> Bool) -> IO [FilePath] +listFilesMatching path pred = fmap (filter pred) $ listFilesR path + +listFilesR :: FilePath -> IO [FilePath] +listFilesR = listFilesR' . (<> "/") + +listFilesR' path = let + isDODD :: String -> Bool + isDODD f = not $ (List.isSuffixOf "/." f) || (List.isSuffixOf "/.." f) + -- isDODD _ = True + + listDirs :: [FilePath] -> IO [FilePath] + listDirs = filterM doesDirectoryExist . fmap (<> "/") + + listFiles :: [FilePath] -> IO [FilePath] + listFiles = filterM doesFileExist + + joinFN :: String -> String -> FilePath + joinFN p1 p2 = mconcat [p1, p2] + + in do + allfiles <- getDirectoryContents path + no_dots <- filterM (return . isDODD) (map (joinFN path) allfiles) + dirs <- listDirs no_dots + subdirfiles <- (mapM (listFilesR'{- . (<> "/")-}) dirs >>= return . concat) + files <- listFiles no_dots + return $ files ++ subdirfiles diff --git a/src/Language/Modulo/Parse.hs b/src/Language/Modulo/Parse.hs --- a/src/Language/Modulo/Parse.hs +++ b/src/Language/Modulo/Parse.hs @@ -17,10 +17,14 @@ module Language.Modulo.Parse ( parse, parseName, + parsePrimType, + parsePrimTypeMaybe, unsafeParseFile ) where import Control.Monad +import Control.Arrow +import Data.Monoid import Data.Maybe import Control.Applicative hiding ((<|>), optional, many) @@ -48,6 +52,20 @@ parseName = runParser nameParser () "" -- | +-- Parse a primitive type, returning an error if unsuccessful. +-- +parsePrimType :: String -> Either ParseError PrimType +parsePrimType = fmap unPrimType . runParser primTypeParser () "" + where + unPrimType (PrimType x) = x + +-- | +-- Parse a primitive type, returning an error if unsuccessful. +-- +parsePrimTypeMaybe :: String -> Maybe PrimType +parsePrimTypeMaybe = eitherToMaybe . parsePrimType + +-- | -- Parse a module description from the given file, or fail if unsuccessful. -- -- This unsafe function should not be used in production code. @@ -149,25 +167,30 @@ opaqueParser :: Parser () opaqueParser = reserved lexer "opaque" >> return () +-- To parse a type, we first parse all types whose syntax does not involve +-- post-qualifiers (i.e. pointer and function), then parse the modifiers to +-- generate a qualifier, and apply it to the prefix. I.e. in (a -> b) we first +-- parse a, then (-> b), and modify a by applying (-> b). typeParser :: Parser Type typeParser = do typs <- typeStartParser mods <- typeEndParser return $ mods typs -typeStartParser :: Parser [Type] +typeStartParser :: Parser [(Maybe Name,Type)] typeStartParser = mzero <|> parenTypeParser - <|> single <$> arrayTypeParser - <|> single <$> enumTypeParser - <|> single <$> unionTypeParser - <|> single <$> structTypeParser - <|> single <$> bitfieldTypeParser - <|> single <$> primTypeParser - <|> single <$> aliasTypeParser + <|> (single.returnPair) <$> arrayTypeParser + <|> (single.returnPair) <$> enumTypeParser + <|> (single.returnPair) <$> unionTypeParser + <|> (single.returnPair) <$> structTypeParser + <|> (single.returnPair) <$> bitfieldTypeParser + <|> (single.returnPair) <$> primTypeParser + <|> (single.returnPair) <$> aliasTypeParser +returnPair x = (Nothing,x) -typeEndParser :: Parser ([Type] -> Type) -typeEndParser = foldr (flip c2) head <$> many (ptr <|> func) +typeEndParser :: Parser ([(Maybe Name, Type)] -> Type) +typeEndParser = foldr comp noTypeEnd <$> many (ptr <|> func) where ptr = do llex $ char '*' @@ -176,27 +199,33 @@ llex $ string "->" typ <- typeParser return $ mkFun typ - - mkPtr :: [Type] -> Type - mkPtr [x] = RefType . Pointer $ x - mkPtr _ = error "Can not make pointer of argument head" - -- TODO reflect up to parser hierarchy - mkFun :: Type -> [Type] -> Type - mkFun r as = FunType $ Function as r + noTypeEnd :: [(Maybe Name, Type)] -> Type + noTypeEnd [(_,x)] = x + noTypeEnd _ = error "Unexpected argument head" + + mkPtr :: [(Maybe Name, Type)] -> Type + mkPtr [(_,x)] = RefType . Pointer $ x + mkPtr _ = error "Unexpected argument head" - -- TODO is this (=<=) in Control.Comonad ? - c2 :: ([b] -> c) -> ([a] -> b) -> [a] -> c - c2 g f = g . single . f - + mkFun :: Type -> [(Maybe Name, Type)] -> Type + mkFun r as = FunType $ Function as r + -- TODO is this (=>=) in Control.Comonad ? + comp :: ([(Maybe x,a)] -> b) -> ([(Maybe x,b)] -> c) -> [(Maybe x,a)] -> c + comp g f = f . single . returnPair . g + +-- This is not really a type, but the product used to express the argument to an uncurried function. +-- However, if it is just a one-tuple without a name, it will be treated as an ordinary type. +-- That is (A) -> B is the same as A -> B. + -- TODO support named arguments -parenTypeParser :: Parser [Type] +parenTypeParser :: Parser [(Maybe Name, Type)] parenTypeParser = do llex $ char '(' - typ <- typeParser `sepBy` (llex $ char ',') + types <- maybeNameTypeParser `sepBy` (llex $ char ',') llex $ char ')' - return typ + return $ types arrayTypeParser :: Parser Type arrayTypeParser = do @@ -302,6 +331,8 @@ typ <- typeParser return $ (name, typ) +maybeNameTypeParser :: Parser (Maybe Name, Type) +maybeNameTypeParser = try (fmap (first Just) unameTypeParser) <|> fmap returnPair typeParser -- Extra combinators, not exported occs p = length <$> many p @@ -353,3 +384,5 @@ notSupported x = error $ "Not supported yet: " ++ x +eitherToMaybe (Right x) = Just x +eitherToMaybe (Left _) = Nothing diff --git a/src/Language/Modulo/Rename.hs b/src/Language/Modulo/Rename.hs --- a/src/Language/Modulo/Rename.hs +++ b/src/Language/Modulo/Rename.hs @@ -17,6 +17,7 @@ rename ) where +import Control.Arrow import Control.Exception import Data.List (isSuffixOf) import Data.Maybe (catMaybes) @@ -49,7 +50,7 @@ renameDecl (GlobalDecl n v t) = GlobalDecl (simplify $ qualify mod n) v (renameType t) renameType (PrimType t) = PrimType t - renameType (AliasType n) = AliasType $ simplify $ resolveName (mod : deps) n + renameType (AliasType n) = AliasType $ simplify $ resolveName mod (mod : deps) n renameType (RefType t) = RefType $ renameRefType t renameType (FunType t) = FunType $ renameFunType t renameType (CompType t) = CompType $ renameCompType t @@ -59,7 +60,7 @@ renameRefType (Array t j) = Array (renameType t) j renameFunType :: FunType -> FunType - renameFunType (Function as r) = Function (fmap renameType as) (renameType r) + renameFunType (Function as r) = Function (fmap (second renameType) as) (renameType r) renameCompType :: CompType -> CompType renameCompType (Enum ns) = Enum ns @@ -71,10 +72,10 @@ qualify m (Name n) = QName (modName m) n qualify _ (QName _ _) = error "Name already qualified" -resolveName :: [Module] -> Name -> Name -resolveName ms (QName m n) = QName m n -resolveName ms n@(Name n') = case findName ms n of - Nothing -> error $ "Could not find: " ++ show n' +resolveName :: Module -> [Module] -> Name -> Name +resolveName errorMsgMod deps (QName m n) = QName m n +resolveName errorMsgMod deps n@(Name n') = case findName deps n of + Nothing -> error $ "Could not find '" ++ show n' ++ "' in module " ++ show (modName errorMsgMod) Just m -> QName m n' -- | diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -4,8 +4,9 @@ module Main where -import Control.Monad (when) +import Control.Monad (when, join) import Data.List (find) +import Data.Default import Data.Maybe (fromMaybe, maybeToList) import System.IO import System.Exit @@ -40,9 +41,10 @@ data ModOpt = Help | Version - | Package { getPackage :: String } | Lang { getLang :: ModLang } | Path { getPath :: [ModulePath] } + | LispPackage { getLispPackage :: Maybe String } + | LispPrimBool { getLispPrimBool :: Maybe PrimType } deriving (Eq, Show) readModLang :: Maybe String -> ModOpt @@ -65,10 +67,13 @@ -- TODO accept more than one, separate by commas readPackage :: Maybe String -> ModOpt -readPackage = Package . maybe "user" id +readPackage = LispPackage +readPrimBool :: Maybe String -> ModOpt +readPrimBool = LispPrimBool . (=<<) parsePrimTypeMaybe -version = "modulo-1.5" + +version = "modulo-1.7.2" header = "Usage: modulo [options]\n" ++ "Usage: modulo [options] files...\n" ++ "\n" ++ @@ -81,7 +86,8 @@ (Option ['v'] ["version"] (NoArg Version) "Print version and exit"), (Option ['L'] ["language"] (OptArg readModLang "LANG") "Output language"), (Option ['M'] ["module-path"] (OptArg readModPath "PATH") "Module paths"), - (Option [] ["lisp-package"] (OptArg readPackage "STRING") "Lisp package") + (Option [] ["lisp-package"] (OptArg readPackage "STRING") ("Lisp package (default: " ++ package def ++ ")")), + (Option [] ["lisp-primitive-bool"] (OptArg readPrimBool "STRING") ("Optional primitive boolean type (Char|Int|UChar|UInt...)")) ] main = do @@ -104,10 +110,18 @@ where isPath (Path _) = True isPath _ = False -findPackage opts = fmap getPackage $ find isPackage opts + +findLispPackage :: [ModOpt] -> Maybe String +findLispPackage opts = join $ fmap getLispPackage $ find isLispPackage opts where - isPackage (Package _) = True - isPackage _ = False + isLispPackage (LispPackage _) = True + isLispPackage _ = False + +findLispPrimBool :: [ModOpt] -> Maybe PrimType +findLispPrimBool opts = join $ fmap getLispPrimBool $ find isLispPrimBool opts + where + isLispPrimBool (LispPrimBool _) = True + isLispPrimBool _ = False -- | -- Run as a filter from stdin to stdout. @@ -119,12 +133,13 @@ compileFile opts input output = do let lang = fromMaybe C (findLang opts) let paths = fromMaybe [] (findPath opts) - let package = fromMaybe "user" (findPackage opts) + let lispPackage = findLispPackage opts + let lispPrimBool = findLispPrimBool opts s <- hGetContents input let m = unsafeParse s mr <- unsafeRename paths m - let c = printMod lang mr + let c = printMod lispPackage lispPrimBool lang mr hPutStr output c return () @@ -139,8 +154,17 @@ Left e -> error $ "Parse error: " ++ show e Right m -> m - printMod :: ModLang -> Module -> String - printMod C = printModuleComm - printMod Lisp = printModuleLisp - printMod Haskell = printModuleHaskell + printMod :: Maybe String -> Maybe PrimType -> ModLang -> Module -> String + printMod lp lpm C = printModuleComm + printMod lp lpm Lisp = printModuleLispStyle $ maybeDo setP lp $ setPM lpm $ def + where + setP p s = s { package = p } + setPM pm s = s { primBoolType = pm } + printMod lp lpm Haskell = printModuleHaskell + + +maybeDo :: (a -> b -> b) -> Maybe a -> b -> b +maybeDo f Nothing = id +maybeDo f (Just x) = f x +