Merge pull request #3 from Gurkenglas/stack

Stack now builds exference.

.gitignore

@@ -10,4 +10,4 @@ cabal.sandbox.config
 **/*.gui~
 \#*.gui\#
 Main
-
+.stack-work

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

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
 
 

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
                                   )

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)

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

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

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,17 +67,17 @@ 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.
 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

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: []