exference-1.6.0.0: src/Language/Haskell/Exference/EnvironmentParser.hs
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MonadComprehensions #-}
module Language.Haskell.Exference.EnvironmentParser
( parseModules
, parseModulesSimple
, environmentFromModuleAndRatings
, environmentFromPath
, haskellSrcExtsParseMode
, compileWithDict
)
where
import Language.Haskell.Exference
import Language.Haskell.Exference.ExpressionToHaskellSrc
import Language.Haskell.Exference.BindingsFromHaskellSrc
import Language.Haskell.Exference.ClassEnvFromHaskellSrc
import Language.Haskell.Exference.TypeDeclsFromHaskellSrc
import Language.Haskell.Exference.TypeFromHaskellSrc
import Language.Haskell.Exference.Core.FunctionBinding
import Language.Haskell.Exference.FunctionDecl
import Language.Haskell.Exference.Core.Types
import Language.Haskell.Exference.SimpleDict
import Language.Haskell.Exference.Core.Expression
import Language.Haskell.Exference.Core.ExferenceStats
import Control.DeepSeq
import System.Process
import Control.Applicative ( (<$>), (<*>), (<*) )
import Control.Arrow ( (***) )
import Control.Monad ( when, forM_, guard, forM, mplus, mzero )
import Data.List ( sortBy, find, isSuffixOf )
import Data.Ord ( comparing )
import Text.Printf
import Data.Maybe ( listToMaybe, fromMaybe, maybeToList, catMaybes )
import Data.Either ( lefts, rights )
import Control.Monad.Writer.Strict
import System.Directory ( getDirectoryContents )
import Control.Exception ( try, SomeException )
import Data.Bifunctor ( first, second )
import Language.Haskell.Exts.Syntax ( Module(..), Decl(..), ModuleName(..) )
import Language.Haskell.Exts.Parser ( parseModuleWithMode
, parseModule
, ParseResult (..)
, ParseMode (..)
, defaultParseMode )
import Language.Haskell.Exts.Extension ( Language (..)
, Extension (..)
, KnownExtension (..) )
import Data.List.Split ( chunksOf )
import Control.Monad.Trans.MultiRWS
import Data.HList.ContainsType
import Language.Haskell.Exference.Core.TypeUtils
import qualified Data.Map as M
import qualified Data.IntMap as IntMap
builtInDeclsM :: (Monad m) => MultiRWST r w s m [HsFunctionDecl]
builtInDeclsM = do
let consType = (Cons, TypeArrow
(TypeVar 0)
(TypeArrow (TypeApp (TypeCons ListCon)
(TypeVar 0))
(TypeApp (TypeCons ListCon)
(TypeVar 0))))
tupleConss <- mapM (\(a,b) -> [(a,y) | y <- unsafeReadType0 b])
[ (,) (TupleCon 0) "Unit"
, (,) (TupleCon 2) "a -> b -> (a, b)"
, (,) (TupleCon 3) "a -> b -> c -> (a, b, c)"
, (,) (TupleCon 4) "a -> b -> c -> d -> (a, b, c, d)"
, (,) (TupleCon 5) "a -> b -> c -> d -> e -> (a, b, c, d, e)"
, (,) (TupleCon 6) "a -> b -> c -> d -> e -> f -> (a, b, c, d, e, f)"
, (,) (TupleCon 7) "a -> b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g)"
]
return $ consType : tupleConss
builtInDeconstructorsM :: (Monad m) => MultiRWST r w s m [DeconstructorBinding]
builtInDeconstructorsM = mapM helper ds
where
helper (t, xs) = [ (x,xs,False)
| x <- unsafeReadType0 t
]
ds = [ (,) "(a, b)" [(TupleCon 2, [TypeVar 0, TypeVar 1])]
, (,) "(a, b, c)" [(TupleCon 3, [TypeVar 0, TypeVar 1, TypeVar 2])]
, (,) "(a, b, c, d)" [(TupleCon 4, [TypeVar 0, TypeVar 1, TypeVar 2, TypeVar 3])]
, (,) "(a, b, c, d, e)" [(TupleCon 5, [TypeVar 0, TypeVar 1, TypeVar 2, TypeVar 3, TypeVar 4])]
, (,) "(a, b, c, d, e, f)" [(TupleCon 6, [TypeVar 0, TypeVar 1, TypeVar 2, TypeVar 3, TypeVar 4, TypeVar 5])]
, (,) "(a, b, c, d, e, f, g)" [(TupleCon 7, [TypeVar 0, TypeVar 1, TypeVar 2, TypeVar 3, TypeVar 4, TypeVar 5, TypeVar 6])]
]
-- | Takes a list of bindings, and a dictionary of desired
-- functions and their rating, and compiles a list of
-- RatedFunctionBindings.
--
-- If a function in the dictionary is not in the list of bindings,
-- Left is returned with the corresponding name.
--
-- Otherwise, the result is Right.
compileWithDict :: [(QualifiedName, Float)]
-> [HsFunctionDecl]
-> Either String [RatedHsFunctionDecl]
-- function_not_found or all bindings
compileWithDict ratings binds =
ratings `forM` \(name, rating) ->
case find ((name==).fst) binds of
Nothing -> Left $ show name
Just (_,t) -> Right (name, rating, t)
-- | input: a list of filenames for haskell modules and the
-- parsemode to use for it.
--
-- output: the environment extracted from these modules, wrapped
-- in a Writer that contains warnings/errors.
parseModules :: forall m r w s
. ( m ~ MultiRWST r w s IO
, ContainsType [String] w
)
=> [(ParseMode, String)]
-> m
( [HsFunctionDecl]
, [DeconstructorBinding]
, StaticClassEnv
, [QualifiedName]
, TypeDeclMap
)
parseModules l = do
rawTuples <- lift $ mapM hRead l
let eParsed = map hParse rawTuples
{-
let h :: Decl -> IO ()
h i@(InstDecl _ _ _ _ _ _ _) = do
pprint i >>= print
h _ = return ()
forM_ (rights eParsed) $ \(Module _ _ _ _ _ _ ds) ->
forM_ ds h
-}
-- forM_ (rights eParsed) $ \m -> pprintTo 10000 m >>= print
mapM_ (mTell . (:[])) $ lefts eParsed
let mods = rights eParsed
let ds = getDataTypes mods
typeDeclsE <- getTypeDecls ds mods
lefts typeDeclsE `forM_` (mTell . (:[]))
let typeDecls = M.fromList $ (\x -> (tdecl_name x, x)) <$> rights typeDeclsE
(cntxt@(StaticClassEnv clss insts), n_insts) <- getClassEnv ds typeDecls mods
-- TODO: try to exfere this stuff
(decls, deconss) <- do
stuff <- mapM (hExtractBinds cntxt ds typeDecls) mods
return $ concat *** concat $ unzip stuff
let clssNames = fmap tclass_name clss
let allValidNames = ds ++ clssNames
let
dataToBeChecked :: [(String, HsType)]
dataToBeChecked =
[ ("the instance data for " ++ show i, t)
| insts' <- M.elems insts
, i@(HsInstance _ _ ts) <- insts'
, t <- ts]
++ [ ("the binding " ++ show n, t)
| (n, t) <- decls]
let
check :: String -> HsType -> m ()
check s t = do
findInvalidNames allValidNames t `forM_` \n ->
mTell ["unknown binding '"++show n++"' used in " ++ s]
dataToBeChecked `forM_` uncurry check
mTell ["got " ++ show (length clss) ++ " classes"]
mTell ["and " ++ show (n_insts) ++ " instances"]
mTell ["(-> " ++ show (length $ concat $ M.elems $ insts) ++ " instances after inflation)"]
mTell ["and " ++ show (length decls) ++ " function decls"]
builtInDecls <- builtInDeclsM
builtInDeconstructors <- builtInDeconstructorsM
return $ ( builtInDecls++decls
, builtInDeconstructors++deconss
, cntxt
, allValidNames
, typeDecls
)
where
hRead :: (ParseMode, String) -> IO (ParseMode, String)
hRead (mode, s) = (,) mode <$> readFile s
hParse :: (ParseMode, String) -> Either String Module
hParse (mode, content) = case parseModuleWithMode mode content of
f@(ParseFailed _ _) -> Left $ show f
ParseOk modul -> Right modul
hExtractBinds :: StaticClassEnv
-> [QualifiedName]
-> TypeDeclMap
-> Module
-> m ([HsFunctionDecl], [DeconstructorBinding])
hExtractBinds cntxt ds tDeclMap modul@(Module _ (ModuleName _mname) _ _ _ _ _) = do
-- tell $ return $ mname
eFromData <- getDataConss (sClassEnv_tclasses cntxt) ds tDeclMap [modul]
eDecls <- (++)
<$> getDecls ds (sClassEnv_tclasses cntxt) tDeclMap [modul]
<*> getClassMethods (sClassEnv_tclasses cntxt) ds tDeclMap [modul]
mapM_ (mTell . (:[])) $ lefts eFromData ++ lefts eDecls
-- tell $ map show $ rights ebinds
let (binds1s, deconss) = unzip $ rights eFromData
binds2 = rights eDecls
return $ ( concat binds1s ++ binds2, deconss )
-- | A simplified version of environmentFromModules where the input
-- is just one module, parsed with some default ParseMode;
-- the output is transformed so that all functionsbindings get
-- a rating of 0.0.
parseModulesSimple :: ( ContainsType [String] w
)
=> String
-> MultiRWST r w s IO
( [RatedHsFunctionDecl]
, [DeconstructorBinding]
, StaticClassEnv
, [QualifiedName]
, TypeDeclMap
)
parseModulesSimple s = helper
<$> parseModules [(haskellSrcExtsParseMode s, s)]
where
addRating (a,b) = (a,0.0,b)
helper (decls, deconss, cntxt, ds, tdm) = (addRating <$> decls, deconss, cntxt, ds, tdm)
ratingsFromFile :: String -> IO (Either String [(QualifiedName, Float)])
ratingsFromFile = (fmap . first) show . (try :: IO a -> IO (Either SomeException a))
. fmap (map (\[name, float] -> (parseQualifiedName name, read float)) . chunksOf 2 . words)
. readFile
-- TODO: add warnings for ratings not applied
environmentFromModuleAndRatings :: ( ContainsType [String] w
)
=> String
-> String
-> MultiRWST r w s IO
( [FunctionBinding]
, [DeconstructorBinding]
, StaticClassEnv
, [QualifiedName]
, TypeDeclMap
)
environmentFromModuleAndRatings s1 s2 = do
let exts1 = [ TypeOperators
, ExplicitForAll
, ExistentialQuantification
, TypeFamilies
, FunctionalDependencies
, FlexibleContexts
, MultiParamTypeClasses ]
exts2 = map EnableExtension exts1
mode = ParseMode (s1++".hs")
Haskell2010
exts2
False
False
Nothing
False
(decls, deconss, cntxt, ds, tdm) <- parseModules [(mode, s1)]
r <- lift $ ratingsFromFile s2
case r of
Left e -> do
mTell ["could not parse ratings!",e]
return ([], [], cntxt, [], tdm)
Right ratings -> do
let f (a,b) = declToBinding
$ ( a
, fromMaybe 0.0 (lookup a ratings)
, b
)
return $ (map f decls, deconss, cntxt, ds, tdm)
environmentFromPath :: ( ContainsType [String] w
)
=> FilePath
-> MultiRWST r w s IO
( [FunctionBinding]
, [DeconstructorBinding]
, StaticClassEnv
, [QualifiedName]
, TypeDeclMap
)
environmentFromPath p = do
files <- lift $ getDirectoryContents p
let modules = ((p ++ "/")++) <$> filter (".hs" `isSuffixOf`) files
let ratings = ((p ++ "/")++) <$> filter (".ratings" `isSuffixOf`) files
(decls, deconss, cntxt, dts, tdm) <- parseModules
[ (mode, m)
| m <- modules
, let mode = haskellSrcExtsParseMode m]
rResult <- lift $ ratingsFromFile `mapM` ratings
let rs = [x | Right xs <- rResult, x <- xs]
sequence_ $ do
Left err <- rResult
return $ mTell ["could not parse rating file", err]
(rs' :: [(QualifiedName, Float)]) <- fmap join $ sequence $ do
(rName, rVal) <- rs
return $ do
dIds <- fmap join $ sequence $ do
(dName, _) <- decls
return $ do
return $ do
guard (show rName == show dName)
return (dName, rVal)
case dIds of
[] -> do
mTell ["rating could not be applied: " ++ show rName]
return []
[x] ->
return [x]
_ -> do
mTell ["duplicate function: " ++ show rName]
return []
let f (a,b) = declToBinding
$ ( a
, fromMaybe 0.0 (lookup a rs')
, b
)
return $ (map f decls, deconss, cntxt, dts, tdm)