Made place trees work.

They are super awesome.

src/Data/Wiki.hs

@@ -44,6 +44,7 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Text.Pin as Pin
 
+-- | TODO: thread the Context in, so that we can keep the cache fresh.
 runInternal :: StateT Context (ReaderT Wiki IO) a -> Wiki -> IO a
 runInternal fn = fmap fst . runReaderT (runStateT fn clean)
 
@@ -75,7 +76,7 @@ instance Internal (StateT Context (ReaderT Wiki IO)) where
     location pp = maybe "" fromFile <$> find p where
         (p, pt) = (pin &&& point) pp
         fromFile = link <$> to <*> show
-        to = href (show <$> pt) . uid
+        to = href (show <$> pt) . show
 
 
     -- | Find a pin.
@@ -101,7 +102,7 @@ instance Internal (StateT Context (ReaderT Wiki IO)) where
     -- TODO: relax? build :: Internal c => (FilePath -> File -> c a) -> c [a]
     build fn = mapM (uncurry fn) . filePairs =<< asks listing where
         filePairs dict = map makePair (Map.elems dict)
-        makePair f = (,) (uid f) f
+        makePair f = (,) (slugify (show f) ++ show (uid f)) f
 
 
 data Wiki = Wiki

src/Location.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module Location where
+import Control.Applicative
+import Data.File()
+import Data.Map ( Map )
+import Data.Maybe ( mapMaybe )
+import Data.Set ( Set, (\\) )
+import Data.Tree ( Tree(Node), Forest )
+import Note
+import Internal
+import Text.Pin
+import qualified Data.Graph as Graph
+import qualified Data.List as List
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Tree as Tree
+
+data (Note n) => Bubble n = Bubble
+    { note :: n
+    , size :: Double
+    }
+
+-- Internally resolve a map of i.e. Place -> Pin into a map of Place -> Place
+normalize :: (Internal i, Ord n, Note n) => Map n Pin -> i (Map n n)
+normalize orig = Map.foldWithKey rebuild (pure Map.empty) orig where
+    rebuild k p imap = maybe imap update =<< resolve orig p where
+        update v = Map.insert k v <$> imap
+
+-- Find a note from a pin
+resolve :: (Internal i, Ord n, Note n) => Map n Pin -> Pin -> i (Maybe n)
+resolve dict pin = (findByUid . uid =<<) <$> find pin where
+    findByUid i = List.find ((== i) . uid) $ Map.keys dict
+
+-- Generate an edge, which contains the note, the uid of the note, and
+-- the uids of all children of the note
+edge :: (Note n, Ord n) => Map n n -> n -> (n, Int, [Int])
+edge dict n = (,,) n (uid n) (map uid $ children dict n)
+
+-- Find all children of a note
+children :: (Note n, Ord n) => Map n n -> n -> [n]
+children dict n = Map.findWithDefault [] n $ invert dict
+
+-- Flip a Child -> Parent mapping into a Parent -> [Children] mapping
+invert :: (Note n, Ord n) => Map n n -> Map n [n]
+invert = Map.foldWithKey inv Map.empty where
+    inv k v = Map.insertWith (++) v [k]
+
+-- Edges usable by Data.Graph
+edges :: (Note n, Ord n) => Map n n -> [(n, Int, [Int])]
+edges = map <$> edge <*> Map.elems
+
+-- Find elements in a map that have no parents
+roots :: (Note n, Ord n) => Map n n -> Set n
+roots dict = Set.fromList (Map.elems dict) \\ Set.fromList (Map.keys dict)
+
+-- Generate a tree from a map!
+tree :: (Note n, Ord n) => Map n n -> Forest n
+tree dict = map (fmap vertToNote) (Graph.dfs g vs) where
+    (g, vertToEdge, uidToVert) = Graph.graphFromEdges $ edges dict
+    vs = mapMaybe (uidToVert . uid) . Set.toList $ roots dict
+    vertToNote = (\(n, _, _) -> n) . vertToEdge
+
+
+display :: (Note n, Ord n, Show n) => Map n n -> String
+display = Tree.drawTree . Node "(root)" . map (fmap show) . tree
+
+{-
+ - TODO: Tree -> Buuble Tree
+    data Bubble = Bubble File Size
+    tree :: Directory -> Tree Bubble
+    instance JSON Bubble
+    instance (JSON a) => JSON (Tree a)
+-}

src/Main.hs

@@ -10,6 +10,7 @@ import Data.List ( sort, intercalate )
 import Data.Maybe
 import Data.Wiki
 import Internal
+import Location ( normalize, display )
 import Note ( text, parseNote )
 import Note.Character
 import Note.Era
@@ -26,6 +27,7 @@ data Options = Options
     , optSourceDir :: FilePath
     , optBuildDir  :: Maybe FilePath
     , optTagFile   :: Maybe FilePath
+    , optPlaceTree :: Bool
     , optHelp      :: Bool
     } deriving Show
 
@@ -36,6 +38,7 @@ defaultOptions = Options
     , optSourceDir = "src"
     , optBuildDir  = Nothing
     , optTagFile   = Nothing
+    , optPlaceTree = False
     , optHelp      = False
     }
 
@@ -62,6 +65,10 @@ options =
                                 }) "FILE")
         "the tag file to write to (default `tags`)"
 
+    , Option "p" ["tree"]
+        (NoArg (\opt -> opt{optPlaceTree = True}))
+        "output a tree of the places in the wiki"
+
     , Option "h" ["help"]
         (NoArg (\opt -> opt{optHelp = True}))
         "display this help"
@@ -97,6 +104,7 @@ run opts = do
                 , optBuildDir  = bld
                 , optSourceDir = src
                 , optTagFile   = tagFile
+                , optPlaceTree = drawTree
                 } = opts
 
     files <- locate $ root </> src
@@ -110,9 +118,22 @@ run opts = do
 
     when (isJust bld) $ do
         let dest = root </> fromJust bld
+        clearDir dest
         let writer = doWrite . (dest </>)
         runInternal (build writer) wiki *> putStrLn ""
 
+    when drawTree $ do
+        dict <- runInternal (normalize =<< asks places) wiki
+        mapM_ putStrLn $ lines $ display dict
+
+
+clearDir :: FilePath -> IO ()
+clearDir dest = do
+    exists <- doesDirectoryExist dest
+    createDirectoryIfMissing exists dest
+    files <- filter (not . (== '.') . head) <$> getDirectoryContents dest
+    mapM_ (removeFile . (dest </>)) files
+
 
 doWrite :: (MonadIO i, Internal i) => FilePath -> File -> i ()
 doWrite filename file = do

src/Note.hs

@@ -24,7 +24,6 @@ import Text.Pin ( Pin )
 import Text.Point ( Point(side) )
 import Text.Printf
 import Text.Render
-import Text.Utils
 import qualified Control.Modifier as Mods
 import qualified Data.Set as Set
 import qualified Text.Pin as Pin
@@ -34,7 +33,7 @@ import qualified Text.Symbols as Y
 data Basic = Basic
     { _uid        :: Int
     , _names      :: [Name]
-    , modifiers  :: [Modifier Pin]
+    , modifiers   :: [Modifier Pin]
     , _body       :: Body
     } deriving Show
 
@@ -62,8 +61,8 @@ class Note a where
     -- A unique id; nice if it contains no spaces etc.
     -- the Int in `construct` will be unique, but sometimes you just want
     -- a prettier identifier.
-    uid :: a -> String
-    uid r = printf "%s-%d" (slugify $ primaryName r) (_uid $ basic r)
+    uid :: a -> Int
+    uid = _uid . basic
 
     -- All our names
     -- Comes with a priority level attached
@@ -134,7 +133,6 @@ class Note a where
 instance Note Basic where
     basic = id
 
-
 parseNote :: Int -> GenParser Char st Basic
 parseNote i = parseBasic i Mods.catOrQual
 

src/Note/Place.hs

@@ -3,6 +3,7 @@ import Control.Appearance
 import Control.Applicative hiding ( (<|>) )
 import Control.Name
 import Data.Body
+import Data.Function
 import Data.String.Utils ( strip )
 import Data.Utils
 import Note
@@ -19,11 +20,14 @@ import qualified Data.Set as Set
 data Place = Place
     { base :: Basic
     , size :: Double
-    } deriving (Eq, Ord, Show)
+    } deriving Eq
 
 parent :: Place -> Maybe Pin
 parent = fmap (pin . ref) . maybeHead . apps . body
 
+instance Ord Place where (<=) = (<=) `on` uid
+instance Show Place where show = primaryName
+
 instance Note Place where
     basic = base