Hs2lib-0.4.8: WinDll/Parsers.hs
{-# LANGUAGE RelaxedPolyRec #-}
-----------------------------------------------------------------------------
-- |
-- Module : Windll
-- Copyright : (c) Tamar Christina 2009 - 2010
-- License : BSD3
--
-- Maintainer : tamar@zhox.com
-- Stability : experimental
-- Portability : portable
--
-- Parsers for the preprocessor. Parses using Haskell-src-exts
-- to the simple datatype in \WinDll.Structs.Structures\
--
-----------------------------------------------------------------------------
module WinDll.Parsers where
import Language.Haskell.Exts
import Language.Haskell.Exts.Extension
import qualified Language.Haskell.Exts as Exts
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Comments
import Data.Generics
import Data.IORef
import Data.List
import Data.Char
import Data.Maybe
import System.IO.Unsafe
import System.FilePath
import System.Directory
import Control.Monad
import WinDll.Structs.Structures hiding (Module)
import qualified WinDll.Structs.Structures as WinDll
import WinDll.Session
import WinDll.Version
import WinDll.Utils.Feedback
import WinDll.Structs.PrettyPrinting
import WinDll.Structs.MShow.HaskellSrcExts
import WinDll.Structs.MShow.MShow
import WinDll.Structs.Folds.HaskellSrcExts
import WinDll.Utils.Types
import qualified Debug.Trace as D
-- testFile = "C:\\Users\\Phyx\\Documents\\Haskell\\WinDLL\\test.hs"
testFile = "C:\\Users\\Phyx\\Documents\\Desktop\\native\\GHCDll.hs"
instance Num SrcLoc where
(SrcLoc f l1 c1) - (SrcLoc _ l2 c2) = SrcLoc f (l1-l2) (c1-c2)
(SrcLoc f l1 c1) + (SrcLoc _ l2 c2) = SrcLoc f (l1+l2) (c1+c2)
(SrcLoc f l1 c1) * (SrcLoc _ l2 c2) = SrcLoc f (l1*l2) (c1*c2)
abs (SrcLoc f l c) = SrcLoc f (abs l) (abs c)
signum (SrcLoc f l c) = SrcLoc f (signum l) (signum c)
fromInteger i = SrcLoc [] (fromInteger i) 0
-- instance Ord Decl where
-- compare a b = if (a == b) then EQ else LT
-- | Read a file in, And store it in the list of \WinDll.Module\ and \WinDll.CodeGen.CommentDecl\
readFromFiles :: Exec ()
readFromFiles =
do session <- get
inform _normal "Reading and parsing all dependencies..."
let workset = workingset session
(result, c0) <- liftM unzip $ forM (absPath session : map guessPath ((drop 1 (dependencies workset))++includes session)) pdata
put $ session { workingset = workset { modules = result
, pragmas = catMaybes (parseComments (join c0)) } }
where pdata :: FilePath -> Exec ((WinDll.Module, [CommentDecl]),[Comment])
pdata path =
do (m0,c0) <- parseFromFile path
inform _detail "Converting AST to internal representation..."
moddata' <- convertModule m0 c0
inform _detail "Updating module name..."
let moddata = moddata' { header = (header moddata') { headername = reverse $ drop 1 $ dropWhile (/='.') $ reverse $ takeFileName path } }
inform _detail "Matching and resolving comments..."
let modcomment = matchFunctionsWithComments c0 (findTypeSignatures m0)
inform _detail ("Finished processing " ++ path ++ "...\n")
return ((moddata,modcomment), c0)
fixDependencies :: String -> FilePath
fixDependencies current = let ldata = map (\a-> if a == '.' then pathSeparator else a) current
fdata = ldata++".hs"
in case unsafePerformIO (doesFileExist fdata) of
True -> fdata
False -> ldata ++ ".lhs"
-- | Convert the right comments to the correct pragmas. These are all globally scoped.
-- .
-- . supported pragmas are:
-- . {- @@ HS2LIB_OPTS <opts> @@ -} -=- turn on dynamic options present in this file
-- . {- @@ INSTANCE <name> <count> @@ -} -=- generate type info required to work correctly but also hides the warning of missing data definition
-- . {- @@ IMPORT <list> @@ -} -=- Imports to carry over to the new generated module
-- . {- @@ HS2C <htype> <type>@<size> @@ -} -=- Specifies what to translate the Haskell htype to the C type, but we also need its size in bytes
-- . {- @@ HS2C# <htype> <c#type> @@ -} -=- Specifies what to translate the Haskell htype to the C# type, but we also need its size in bytes
-- . {- @@ HS2HS <htype> <htype> @@ -} -=- Specifies what to translate the Haskell htype should be in terms of a compatible FFI type.
-- . There needs to be an FFIType instance for these types, or be covered by one of the defaults`
-- .
parseComments :: [Comment] -> [Maybe Pragma]
parseComments [] = []
parseComments ((Comment True _ s):xs) = f (trim s): parseComments xs
where f :: String -> Maybe Pragma
f s | "@@ " `isPrefixOf` s && " @@" `isSuffixOf` s = let stack = trim (drop 3 (take (length s - 3) s))
(x:xs) = lexwords stack
name = (map toUpper x)
xs' = if name == (upper_name ++"_OPTS") then tail $ words stack else xs
in if null stack then Nothing else Just (Pragma name xs')
| otherwise = Nothing
trim :: String -> String
trim = reverse . dropWhile (==' ') . reverse . dropWhile (==' ')
parseComments (_ :xs) = parseComments xs
lexwords :: String -> [String]
lexwords [] = []
lexwords str = let res = lex str
(cur,rest) = head res
cur' = case cur of
[] -> []
'"':xs -> init xs : lexwords rest
'-':_ -> let other = lexwords rest
(x:xs) = other
in if null other then cur : other else (cur++x) : xs
x -> x : lexwords rest
in if null res then [] else cur'
-- | Parse a module from file while retaining comments
parseFromFile :: FilePath -> Exec (Module, [Comment])
parseFromFile path =
do inform _detail ("Parsing '" ++ path ++ "'")
result <- liftIO $ parseFileWithComments (defaultParseMode { extensions = (TemplateHaskell:BangPatterns:NamedFieldPuns:ExplicitForall:glasgowExts), parseFilename = path }) path
case result of
(ParseOk a) -> return a
(ParseFailed loc str) -> die (exename ++ " parse failure, reason: " ++ str ++ " at " ++ show loc)
-- | Finds all the type declarations from a given file.
findTypeSignatures :: Module -> [Decl]
findTypeSignatures = listify inner
where inner (TypeSig _ _ _) = True
inner _ = False
-- | Finds all the type synonym declarations from a given file.
findTypeDecl :: Module -> [Decl]
findTypeDecl = listify inner
where inner (TypeDecl _ _ _ _) = True
inner _ = False
-- | Finds all the foreign export declarations in a file
findForeignExports :: Module -> [Decl]
findForeignExports = listify inner
where inner (ForExp _ _ _ _ _) = True
inner _ = False
-- | Finds all the newtype or data declarations withing the given structure
findDataDeclarations :: Module -> [Decl]
findDataDeclarations = listify inner
where inner (DataDecl _ _ _ _ _ _ _) = True
inner _ = False
-- | Finds all the Storable instances declarations
findStorableDeclarations :: Module -> [Decl]
findStorableDeclarations = listify inner
where inner (InstDecl _ _ name _ _ ) = "Storable" `elem` (findStrings name)
inner _ = False
-- | Match function and comments to eachother and determine which comments indicate out special -- \@\@ comment flag
matchFunctionsWithComments :: [Comment] -> [Decl] -> [CommentDecl]
matchFunctionsWithComments comments decls =
let directives = filter (\t->"@@" `isPrefixOf` strip (readComment t)) comments
in merge $ catMaybes $ map (matchDecl decls) (map convertComment directives)
where readComment :: Comment -> String
readComment (Comment _ _ s) = s
convertComment :: Comment -> MyComment
convertComment (Comment _ l s) = MyComment l s
strip :: String -> String
strip = dropWhile isSpace
maxScore :: Int
maxScore = 500
getScore :: SrcLoc -> Int
getScore (SrcLoc _ l f) = if l > 0 then l else maxScore -- l*l + f*f
convertLoc :: SrcSpan -> SrcLoc
convertLoc (SrcSpan n l f _ _) = SrcLoc n l f
matchDecl :: [Decl] -> MyComment -> Maybe CommentDecl
matchDecl decls (MyComment l s) =
let ordered = sort $ map (\t@(TypeSig d _ _)->(getScore (d- (convertLoc l)),([s],t))) decls
value = head ordered
score = fst value
in if score < maxScore then Just (snd value) else Nothing
merge :: [CommentDecl] -> [CommentDecl]
merge [] = []
merge x = map (foldr1 (\(a,_) (b,f)->(a++b,f))) $ groupBy (\a b->snd a==snd b) x
-- | Standard imports list for all generated moduels
stdImports :: [Import]
stdImports = ["WinDll.Lib.NativeMapping"
,"WinDll.Lib.Tuples"
,"WinDll.Lib.InstancesTypes"
,"Foreign"
,"Foreign.C"
,"Foreign.C.Types"
,"Foreign.Ptr"
,"Foreign.Marshal.Alloc"
,"Foreign.Marshal.Utils"
,"Foreign.ForeignPtr"
]
-- | Convert the parsed Haskell-src-exts to the internal Module definition.
-- A nother limitation to get this done on time, is that i don't support infix constructors
convertModule :: Module -> [Comment] -> Exec WinDll.Module
convertModule m@(Module (SrcLoc file _ _) (ModuleName name) _ _ _ _ decl) comments =
let header = Header name []
exports = map createExport t_func
datatypes = map createDataType t_data
functions = map createFunction t_func
tdecl = map createTypeSyn t_type
instances = map createInstance t_inst
foreigns = map createForeign t_fexpr
t_func = filter isExport $ fixC $ matchFunctionsWithComments comments (findTypeSignatures m)
t_data = findDataDeclarations m
t_type = findTypeDecl m
t_inst = findStorableDeclarations m
t_fexpr = findForeignExports m
in do session <- get
let workset = workingset session
newset = workset { n_exports = n_exports workset ++ foreigns }
newsess = session { workingset = newset }
put newsess
return $ WinDll.Module header file (name:stdImports) exports datatypes functions instances tdecl
where isExport :: CommentDecl -> Bool
isExport (flags, _) = any (isPrefixOf "export") (map (map toLower) flags)
strip :: String -> String
strip = dropWhile isSpace
prep :: String -> String
prep = strip . drop 2 . strip
fixC :: [CommentDecl] -> [CommentDecl]
fixC = map (\(c,d)->(map prep c,d))
createFunction :: CommentDecl -> Function
createFunction (p,(TypeSig _ name' typ')) = Function name (tlength typ - 1) ty ann typ
where args = findStrings typ
t_name = head $ findStrings name'
typ = simplify typ'
(ann ,ty) = upgradeType noAnn typ
export = strip $ drop 6 $ head' $ filter ((=="export").map toLower.takeWhile (not.(\a->isSpace a || a=='='))) p
name = t_name
createForeign :: Decl -> HaskellExport
createForeign (ForExp _ cc _ name ty) = HaskellExport (convert cc) noAnn (Export name' name' typ typ)
where convert Exts.StdCall = WinDll.Session.StdCall
convert Exts.CCall = WinDll.Session.CCall
typ = simplify ty
name' = mkName name
mkName (Exts.Ident s) = s
mkName (Exts.Symbol s) = s
createExport :: CommentDecl -> Export
createExport (p,(TypeSig _ name' _type)) = Export name exportn ty typ
where t_name = head $ findStrings name'
(_ ,ty) = upgradeType noAnn typ
typ = simplify _type
export = strip $ drop 6 $ head' $ filter ((=="export").map toLower.takeWhile (not.(\a->isSpace a || a=='='))) p
exportn = if ("=" `isPrefixOf` export) then (takeWhile (not.isSpace).strip.tail) export else name
name = t_name
head' :: [[a]] -> [a]
head' [] = []
head' (x:xs) = x
createTypeSyn :: Decl -> WinDll.TypeDecL
createTypeSyn (TypeDecl _ name bind typ) = TypeDecL (head $ findStrings name)
(findStrings bind) (simplify typ)
createDataType :: Decl -> WinDll.DataType
createDataType (DataDecl _ Exts.DataType _ name types constr _) = WinDll.DataType (head $ findStrings name) (findStrings types) (map (mkConstr (head $ findStrings name)) constr) NoTag
createDataType (DataDecl _ Exts.NewType _ name types constr _) = WinDll.NewType (head $ findStrings name) (findStrings types) (head $ map (mkConstr (head $ findStrings name)) constr) NoTag
mkConstr str = (\(QualConDecl _ _ _ con)->case con of
(ConDecl cname vars) -> Constr xname (genFreeVars name 1 vars)
where name = let val = map toLower (str++"_"++xname++"_var")
in (val++)
xname = (head $ findStrings cname)
(RecDecl cname vars) -> Constr (head $ findStrings cname) (genNamedVars vars)
(InfixConDecl a name b) -> error "Parse error: Sorry, the current version of windll does not support infix constructor types.")
createInstance :: Decl -> WinDll.Instance
createInstance (InstDecl _ con name types decls)
= QualifiedInstance (head $ findStrings name) types
-- | Generate free variable names
genFreeVars :: (String -> String) -> Int -> [BangType] -> AnnNamedTypes
genFreeVars f _ [] = []
genFreeVars f n (x:xs) = let (ann, ty) = upgradeType noAnn t
t = getTypeFromBang x
name = (f.show) n
ann' = ann{ annArrayIsList = True, annArrayIndices = [] }
value = case isOnlyList t of
False -> AnnType name ty ann t
True -> AnnType name t ann' t
in value : genFreeVars f (n+1) xs
-- | Strip a layer away and get to the real type.
getTypeFromBang :: BangType -> WinDll.Type
getTypeFromBang (BangedTy t) = t
getTypeFromBang (UnBangedTy t) = t
getTypeFromBang (UnpackedTy t) = t
-- | Create elements of constructor for records.
genNamedVars :: Data b => [([b],BangType)] -> AnnNamedTypes
genNamedVars [] = []
genNamedVars (((x:_),a):xs) = let (ann,val) = upgradeType noAnn ty
ann' = ann{ annArrayIsList = True, annArrayIndices = [] }
ty = getTypeFromBang a
name = head $ findStrings x
value = case isOnlyList ty of
False -> AnnType name val ann ty
True -> AnnType name ty ann' ty
in value : genNamedVars xs
-- | See if the type is just a list type
isOnlyList :: Exts.Type -> Bool
isOnlyList (Exts.TyParen a) = isOnlyList a
isOnlyList (Exts.TyList _) = True
isOnlyList _ = False
-- | Find all type strings, taking care to support things like type application
findTypeString :: Language.Haskell.Exts.Syntax.Type -> [String]
findTypeString (TyForall m c t ) = findTypeString t
findTypeString (TyFun t1 t2 ) = (findTypeString t1)++(findTypeString t2)
findTypeString (TyTuple b t ) = ["(" ++ foldr1 (\a b->a++","++b) (concatMap findTypeString t) ++ ")"]
findTypeString (TyList t ) = ["[" ++ unwords (findTypeString t) ++ "]"]
findTypeString (TyApp t1 t2 ) = [unwords (findTypeString t1 ++ findTypeString t2)]
findTypeString (TyVar n ) = findStrings' n
findTypeString (TyCon q ) = findStrings' q
findTypeString (TyParen p ) = ["(" ++ foldr1 (\a b->a++" -> "++b) (findTypeString p) ++ ")"]
findTypeString (TyInfix t1 q t2) = findTypeString t1 ++ findStrings' q ++
findTypeString t2
findTypeString (TyKind t k ) = findTypeString t
-- | Rename the AST to not treat SpecialCons special but just as strings
renameAST :: Data a => a -> a
renameAST = everywhere (mkT inner)
where inner :: QName -> QName
inner (Special x) = UnQual (Symbol (mshow x))
inner x = x
-- | Merge the specialized Type version along with the generic version
findStrings :: Data a => a -> [String]
findStrings = findStrings' -- `extQ` findTypeString).renameAST
-- | The SYB traversals do too much work, I need to figure out how to solve this. (it applies a matching function in both cases.
mkUnique :: [String] -> [String]
mkUnique x = filter condition x
where condition y = let y' = y ++ " "
y'' = ' ':y
y''' = (' ':y) ++ " "
in not (case y of
[] -> True
(o:_) -> any (\a->y' `isPrefixOf` a || y'' `isSuffixOf` a || y''' `isInfixOf` a) x)
-- | Upgrade a type by performing actions such as identifying list
-- and changing the type to also pass along list counters
upgradeType :: Ann -> Exts.Type -> (Ann, Exts.Type)
upgradeType ann x =
let t' = updateType True ann' t
t = simplify x
lst' = findListIndices ty'
ann' = ann{annArrayIndices = lst'}
ty' = analyzeType True t'
in (ann', ty')
-- | Check to see if the last argument of the type is a list
-- in which case we should change the Int before it to Ptr CInt
analyzeType :: Bool -> Exts.Type -> Exts.Type
analyzeType esc t =
let t' = everywhere (mkT embedded) t
lst = findListIndices t'
arr' = tlength t' - 1
part = arr' `elem` lst
ty' = if part
then changeType esc arr' (\val -> case val of
Exts.TyCon (Exts.UnQual (Exts.Ident "Int")) -> (Exts.TyApp
(Exts.TyCon $ Exts.UnQual $ Exts.Ident "Ptr")
(Exts.TyCon $ Exts.UnQual $ Exts.Ident $ if esc then "CInt" else "Int"))
_ -> val) t'
else t'
in ty' -- D.trace ("IN: " ++ mshowM 2 t') $ D.trace ("OUT: " ++ mshowM 2 ty') $ D.trace (show arr' ++ " - " ++ show lst) ty'
where embedded :: Exts.Type -> Exts.Type
embedded (Exts.TyParen a) = (Exts.TyParen (analyzeType esc a))
embedded x = x
-- | Update the n-th element of the type with whatever we want
changeType :: Bool -> Int -> (Exts.Type -> Exts.Type) -> Exts.Type -> Exts.Type
changeType _esc n f ty = fst $ (foldTypeIO alg ty) 0
where alg :: TypeAlgebraIO (Int -> (Exts.Type, Int))
alg = (\a b c i -> let (c', i') = c i
in (Exts.TyForall a b c', i')
,\a b i -> let (a', i' ) = a i
(b', i'') = b i'
in (Exts.TyFun a' b', i'')
,\a b i -> let (b', i') = app b i
in (Exts.TyTuple a b', i)
,\a i -> let (a', i') = a i
in (Exts.TyList a', i')
,\o a b i -> let (a', i' ) = a i
(b', i'') = b i'
ix = if o then i'' else i'
in (Exts.TyApp a' b', ix) -- i'')
,\a i -> let i' = i + 1
a' = Exts.TyVar a
in if i' == n
then (f a', i')
else (a' , i')
,\a i -> let i' = i + 1
a' = Exts.TyCon a
in if i' == n
then (f a', i')
else (a' , i')
,\a i -> let (a', i') = a i
in (Exts.TyParen a', i')
,\a b c i -> let (a', i' ) = a i
(c', i'') = c i'
in (Exts.TyInfix a' b c', i'')
,\a b i -> let (a', i') = a i
in (Exts.TyKind a' b, i')
)
app :: [Int -> (Exts.Type, Int)] -> Int -> ([Exts.Type], Int)
app [] i = ([], i)
app (x:xs) i = let (x' , i' ) = x i
(xs', i'') = app xs i'
in (x':xs', i'')
-- | Update a type according to the annotations present
updateType :: Bool -> Ann -> Exts.Type -> Exts.Type
updateType esc ann = everywhere (mkT pushType)
where -- | Types to update
pushType :: Exts.Type -> Exts.Type
pushType (Exts.TyFun a b) = let f x = case isIOList x of
True -> Exts.TyFun
(Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int")
False -> id
g x = case isIOList x of
True -> Exts.TyFun
(Exts.TyApp
(Exts.TyCon $ Exts.UnQual $ Exts.Ident "Ptr")
(Exts.TyCon $ Exts.UnQual $ Exts.Ident $ if esc then "CInt" else "Int"))
x
False -> x
in f a $ Exts.TyFun a (g b)
-- pushType (Exts.TyApp a b) = let f x = case isList x of
-- True -> Exts.TyFun
-- (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int") x
-- False -> x
-- in if isIO a
-- then simplify (move a $ f b)
-- else Exts.TyApp a b
pushType x = x
-- | Move an IO declaration inwards.
move :: Exts.Type -> Exts.Type -> Exts.Type
move io (Exts.TyFun a b) = Exts.TyFun a (Exts.TyApp io b)
move io rest = Exts.TyApp io rest
-- | Identifies locations within a Type where lists are found
-- The indices provided are the locations of the size variables
-- of arrays. The counters start at 0 and not 1 anymore.
-- So keep this in mind :)
findListIndices :: Exts.Type -> [Int]
findListIndices ty = coords (embed ty)
where embed :: Exts.Type -> [Bool]
embed (Exts.TyFun a b) = let res = isList a
in if isFun b
then res:embed b
else res:[isIOList b]
embed (Exts.TyParen a) = embed a
embed _ = []
coords :: [Bool] -> [Int]
coords b = [i | (x,i) <- zip b [(-1)..], x]
-- | A variant of isList that looks inside IO
isIOList :: Exts.Type -> Bool
isIOList (Exts.TyApp a b) = if isIO a
then isList b
else False
isIOList x = isList x
-- | Update the n-th element of the type with whatever we want,
-- only looking at the amount of (->) constructors.
processTypeNode :: Int -> (Exts.Type -> Exts.Type) -> Exts.Type -> Exts.Type
processTypeNode n f ty = fst $ (foldTypeIO alg ty) 1
where alg :: TypeAlgebraIO (Int -> (Exts.Type, Int))
alg = (\a b c i -> let (c', i') = c i
in (Exts.TyForall a b c', i')
,\a b i -> let (a', i' ) = a i
(b', i'') = b (i + 1)
value = Exts.TyFun (if i == n then f a' else a')
(if i+1 == n then f b' else b')
in (value , i'')
,\a b i -> let (b', i') = app b i
in (Exts.TyTuple a b', i)
,\a i -> let (a', i') = a i
in (Exts.TyList a', i')
,\o a b i -> let (a', i' ) = a 0
(b', i'') = b 0
in (Exts.TyApp a' b', i)
,\a i -> (Exts.TyVar a, i)
,\a i -> (Exts.TyCon a, i)
,\a i -> let (a', i') = a i
in (Exts.TyParen a', i')
,\a b c i -> let (a', i' ) = a i
(c', i'') = c i'
in (Exts.TyInfix a' b c', i'')
,\a b i -> let (a', i') = a i
in (Exts.TyKind a' b, i')
)
app :: [Int -> (Exts.Type, Int)] -> Int -> ([Exts.Type], Int)
app [] i = ([], i)
app (x:xs) i = let (x' , i' ) = x i
(xs', i'') = app xs i'
in (x':xs', i'')
-- | Updates a type to that which uses IO
mkIO :: Exts.Type -> Exts.Type
mkIO ty = let arr = tlength ty
mk = simplify . Exts.TyApp (Exts.TyCon $ Exts.UnQual $ Exts.Ident "IO")
in if isIO ty
then ty
else if arr == 1 -- if there are no arguments, just directly apply mk
then mk ty
else processTypeNode arr mk ty
-- | Checks to see if the function being returned is in IO
isIO :: Exts.Type -> Bool
isIO ty = let tys = collectLessTypes ty
ret = last tys
in "IO" `isPrefixOf` ret
-- simpleTest :: FilePath -> [CommentDecl]
-- simpleTest path = let (m0, c0) = unsafePerformIO $ parseFromFile path
-- in matchFunctionsWithComments c0 (findTypeSignatures m0)
-- test :: IO WinDll.Module
-- test = fmap (uncurry convertModule) (parseFromFile testFile)