diff --git a/.gitignore b/.gitignore index 82a0444..c4cdf0e 100644 --- a/.gitignore +++ b/.gitignore @@ -10,4 +10,4 @@ cabal.sandbox.config **/*.gui~ \#*.gui\# Main - +.stack-work diff --git a/README.md b/README.md index ac96c41..e41c2b3 100644 --- a/README.md +++ b/README.md @@ -37,6 +37,14 @@ cabal build cabal run -- "(Show b) => (a->b) -> [a] -> [String]" ~~~~ +Alternatively: + +~~~~ +git clone git@github.com:lspitzner/exference.git +cd exference +stack build +~~~~ + # Usage notes There are certain types of queries where *Exference* will not be able to find diff --git a/exference.cabal b/exference.cabal index 3e6dca5..bf2f3c8 100644 --- a/exference.cabal +++ b/exference.cabal @@ -117,7 +117,7 @@ Library containers, pretty >= 1.1, deepseq >=1.4.1.1 && <1.5, - deepseq-generics >=0.2.0.0 && < 0.3, + deepseq-generics >=0.1.1.2 && < 0.3, unordered-containers >= 0.2.5 && < 0.3, hashable >=1.2.4.0 && <1.3, pqueue >=1.3.1 && < 1.4, @@ -133,7 +133,7 @@ Library directory, bifunctors, safe, - lens >= 4.12 && < 4.13, + lens >= 4.12 && < 4.15, multistate >= 0.6.2 diff --git a/src-exference/Main.hs b/src-exference/Main.hs index 904e6bf..c81c03d 100644 --- a/src-exference/Main.hs +++ b/src-exference/Main.hs @@ -271,7 +271,7 @@ main = runO $ do when (verbosity>0) $ lift $ putStrLn "[running findExpressionsWithStats ..]" let tree = chunkSearchTree $ last $ findExpressionsWithStats $ input {input_maxSteps = 8192} - let showf (total,processed,expression,_) + let showf (total,processed,expression) = ( printf "%d (+%d):" processed (total-processed) , showExpressionPure qNameIndex $ simplifyExpression expression ) diff --git a/src-exference/MainTest.hs b/src-exference/MainTest.hs index ef2833b..7360720 100644 --- a/src-exference/MainTest.hs +++ b/src-exference/MainTest.hs @@ -665,7 +665,7 @@ printSearchTree h (bindings, deconss, sEnv) = sequence_ $ do (Just 256) h let tree = chunkSearchTree $ last $ findExpressionsWithStats input - let showf (total,processed,expression,_) + let showf (total,processed,expression) = printf "%d (+%d): %s" processed (total-processed) (showExpressionPure qNameIndex expression) diff --git a/src/Language/Haskell/Exference/Core/ExferenceStats.hs b/src/Language/Haskell/Exference/Core/ExferenceStats.hs index a07f486..be4aedd 100644 --- a/src/Language/Haskell/Exference/Core/ExferenceStats.hs +++ b/src/Language/Haskell/Exference/Core/ExferenceStats.hs @@ -1,27 +1,12 @@ module Language.Haskell.Exference.Core.ExferenceStats ( ExferenceStats (..) , BindingUsages - , emptyBindingUsages - , incBindingUsage ) where - - import Data.Map.Strict as M - - - type BindingUsages = M.Map String Int -emptyBindingUsages :: BindingUsages -emptyBindingUsages = M.empty - -incBindingUsage :: String -> BindingUsages -> BindingUsages -incBindingUsage s m = case M.lookup s m of - Nothing -> M.insert s 1 m - Just b -> M.insert s (b+1) m - data ExferenceStats = ExferenceStats { exference_steps :: Int , exference_complexityRating :: Float diff --git a/src/Language/Haskell/Exference/Core/Internal/Exference.hs b/src/Language/Haskell/Exference/Core/Internal/Exference.hs index 86ad6a6..5b5cf63 100644 --- a/src/Language/Haskell/Exference/Core/Internal/Exference.hs +++ b/src/Language/Haskell/Exference/Core/Internal/Exference.hs @@ -48,12 +48,12 @@ import Data.Maybe ( maybeToList, listToMaybe, fromMaybe, catMaybes, mapMaybe, is import Control.Arrow ( first, second, (***) ) import Control.Monad ( when, unless, guard, mzero, replicateM , replicateM_, forM, join, forM_, liftM ) -import Control.Applicative ( (<$>), (<*>), (*>), (<|>) ) +import Control.Applicative ( (<$>), (<*>), (*>), (<|>), empty ) import Data.List ( partition, sortBy, groupBy, unfoldr ) import Data.Ord ( comparing ) import Data.Function ( on ) import Data.Functor ( ($>) ) -import Data.Monoid ( mempty, First(First), getFirst, mconcat, Any(..), Endo(..), Sum(..) ) +import Data.Monoid ( Any(..), Endo(..), Sum(..) ) import Data.Foldable ( foldMap, sum, asum, traverse_ ) import Control.Monad.Morph ( lift ) import Data.Typeable ( Typeable ) @@ -193,7 +193,7 @@ findExpressions (ExferenceInput rawType rootFindExpressionState = FindExpressionsState 0 0 - emptyBindingUsages + M.empty #if BUILD_SEARCH_TREE (initialSearchTreeBuilder initNodeName (ExpHole 0)) #endif diff --git a/src/Language/Haskell/Exference/Core/SearchTree.hs b/src/Language/Haskell/Exference/Core/SearchTree.hs index f9debbe..4e14ae1 100644 --- a/src/Language/Haskell/Exference/Core/SearchTree.hs +++ b/src/Language/Haskell/Exference/Core/SearchTree.hs @@ -25,13 +25,13 @@ import Control.Monad.Reader import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import Data.Hashable ( Hashable ) +import Control.Lens hiding ( children ) type SearchTreeValue = ( Int -- total number of children , Int -- number of processed children , Expression -- expression - , Bool -- processed ) type SearchTree = Tree SearchTreeValue @@ -41,42 +41,22 @@ type SearchTreeBuilder a = ( [(a, a, Expression)] -- id, parentid, expr, , [a] -- processed list ) -type SearchTreeBuilderTemp a = ( HM.HashMap a Expression - , HM.HashMap a [a] - ) - buildSearchTree :: forall a . (Eq a, Hashable a) => SearchTreeBuilder a -> a -> SearchTree -buildSearchTree (assocs,processed) root = - r - where - r :: SearchTree - r = ff pureTree - isProcessed (_,_,_,x) = x - ff (Node (x,e) ts) - | eval <- HS.member x processedSet - , subtrees <- map ff ts - = Node ( 1 + length (concatMap flatten ts) - , if eval || not (null ts) - then 1 + length (filter isProcessed - $ concatMap flatten subtrees) - else 0 - , e - , eval) - subtrees - processedSet = HS.fromList processed - pureTree :: Tree (a,Expression) - pureTree = runReader (unfoldTreeM f root) (mv,mp) - f :: a -> Reader (SearchTreeBuilderTemp a) ((a,Expression), [a]) - f x = do - (mValues, mChildren) <- ask - return $ ((x, mValues HM.! x), fromMaybe [] $ HM.lookup x mChildren) - mv = HM.fromList $ map (\(i,_,v) -> (i,v)) assocs - mp = HM.fromListWith (++) - $ assocs >>= \(i,p,_) -> if i==p then [] else [(p, [i])] +buildSearchTree (assocs,processed) root = ff $ unfoldTree (\x -> (x, children x)) root where + ff (Node x xs) + | subtrees <- map ff xs + = Node ( 1 + sumOf (folded . to rootLabel . _1) subtrees + , if elemProcessed x then 1 else 0 + sumOf (folded . to rootLabel . _2) subtrees + , values x) + subtrees + elemProcessed = flip HS.member $ HS.fromList processed + values = (HM.!) $ HM.fromList $ map (\(i,_,v) -> (i,v)) assocs + children = fromMaybe [] . flip HM.lookup + (HM.fromListWith (++) $ assocs >>= \(i,p,_) -> if i==p then [] else [(p, [i])]) initialSearchTreeBuilder :: a -> Expression -> SearchTreeBuilder a initialSearchTreeBuilder x e = ([(x,x,e)],[]) @@ -87,8 +67,8 @@ filterSearchTreeN :: Int -> SearchTree -> SearchTree filterSearchTreeN n (Node d ts) = Node d (ts >>= f) where f :: SearchTree -> [SearchTree] - f (Node d'@(k,_,_,_) ts') | n>k = [] - | otherwise = [Node d' $ ts' >>= f] + f (Node d'@(k,_,_) ts') | n>k = [] + | otherwise = [Node d' $ ts' >>= f] -- removes all nodes that have less than n total nodes (incl. self) -- e.g. if n==2, all nodes without children are removed. @@ -96,8 +76,8 @@ filterSearchTreeProcessedN :: Int -> SearchTree -> SearchTree filterSearchTreeProcessedN n (Node d ts) = Node d (ts >>= f) where f :: SearchTree -> [SearchTree] - f (Node d'@(_,k,_,_) ts') | n>k = [] - | otherwise = [Node d' $ ts' >>= f] + f (Node d'@(_,k,_) ts') | n>k = [] + | otherwise = [Node d' $ ts' >>= f] -- limits depth of tree takeSearchTree :: Int -> SearchTree -> SearchTree diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..d94a3cc --- /dev/null +++ b/stack.yaml @@ -0,0 +1,11 @@ +resolver: lts-5.18 +packages: +- '.' +extra-deps: +- FPretty-1.1 +- hood-0.3 +- multistate-0.7.1.1 +flags: + exference: + build-executables: false +extra-package-dbs: [] \ No newline at end of file