Write tangle

4 files changed, 74 insertions, 2 deletions

diff --git a/lyt.cabal b/lyt.cabal
index 01c150f..5f55390 100644
--- a/lyt.cabal
+++ b/lyt.cabal
@@ -30,7 +30,7 @@ executable lyt
   default-language:    Haskell2010
   default-extensions:  DeriveDataTypeable
                      , DeriveGeneric
-  -- other-extensions:
+  other-extensions:    RecordWildCards
   ghc-options:         -Wall
                        -fwarn-tabs
                        -fwarn-incomplete-uni-patterns
@@ -38,5 +38,7 @@ executable lyt
                        -fwarn-auto-orphans
   main-is:             Main.hs
   other-modules:       Fragment
+                     , Tangle
   build-depends:       base >=4.6 && <4.7
+                     , containers >=0.5 && <0.6
                      , parsec >=3.1.3 && <3.2
diff --git a/src/Fragment.hs b/src/Fragment.hs
index 4a12d5c..14172da 100644
--- a/src/Fragment.hs
+++ b/src/Fragment.hs
@@ -12,7 +12,11 @@ PARTICULAR PURPOSE.  See the GNU General Public License for more details.
 You should have received a copy of the GNU General Public License along with
 this program.  If not, see <http://www.gnu.org/licenses/>. -}
 
+{-# LANGUAGE RecordWildCards #-}
 module Fragment ( Fragment
+                , CodeOrReference(..)
+                , isBlockCode
+                , blockName, blockContents
                 , parseStdin
                 , parseFile) where
 
@@ -30,6 +34,18 @@ data Fragment = Documentation String
               | BlockCode String [CodeOrReference]
               deriving (Eq, Show, Data, Typeable, Generic)
 
+isBlockCode :: Fragment -> Bool
+isBlockCode (Documentation {..}) = False
+isBlockCode (BlockCode {..}) = True
+
+blockName :: Fragment -> String
+blockName (Documentation {..}) = error "Documentation fragments are unnamed"
+blockName (BlockCode name _) = name
+
+blockContents :: Fragment -> [CodeOrReference]
+blockContents (Documentation {..}) = error "Documentation fragments have no code"
+blockContents (BlockCode _ body) = body
+
 data CodeOrReference = Code String
                      | Reference String
                      deriving (Eq, Show, Data, Typeable, Generic)
diff --git a/src/Main.hs b/src/Main.hs
index d69710c..74ea1d2 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -18,6 +18,7 @@ import System.Environment (getArgs)
 import System.Exit (exitFailure)
 
 import Fragment (parseFile, parseStdin)
+import Tangle (tangle)
 
 main :: IO ()
 main = do
@@ -26,7 +27,9 @@ main = do
               [] -> parseStdin
               [f] -> parseFile f
               _ -> usage >> exitFailure
-  print parsed
+  case parsed of
+    Left err -> print err >> exitFailure
+    Right ok -> print $ tangle ok
 
 usage :: IO ()
 usage = putStrLn "usage: lyt [file]"
diff --git a/src/Tangle.hs b/src/Tangle.hs
new file mode 100644
index 0000000..049c497
--- /dev/null
+++ b/src/Tangle.hs
@@ -0,0 +1,51 @@
+{- Copyright © 2015 Benjamin Barenblat
+
+This program is free software: you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free Software
+Foundation, either version 3 of the License, or (at your option) any later
+version.
+
+This program is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License along with
+this program.  If not, see <http://www.gnu.org/licenses/>. -}
+
+module Tangle (tangle) where
+
+import Control.Exception (assert)
+import Control.Monad (liftM)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+
+import Fragment (Fragment, isBlockCode, blockName, blockContents,
+                 CodeOrReference(Code, Reference))
+
+type FragmentGraph = Map String [CodeOrReference]
+
+tangle :: [Fragment] -> Either String String
+tangle fragments =
+  case filter isBlockCode fragments of
+    [] -> Right ""
+    codeBlocks@(root:_) ->
+      expandBlock (fragmentGraph codeBlocks) (blockName root)
+
+fragmentGraph :: [Fragment] -> FragmentGraph
+fragmentGraph frags =
+  Map.fromListWith (++) $
+    map (\block -> blockToPair $ assert (isBlockCode block) block) frags
+  where blockToPair frag = (blockName frag, blockContents frag)
+
+expandBlock :: FragmentGraph -> String -> Either String String
+expandBlock fragments name =
+  case Map.lookup name fragments of
+    Nothing -> Left $ "Desired node " ++ name ++ " not in fragment graph"
+    Just block -> concatMapM (expandBlockBody1 fragments) block
+
+expandBlockBody1 :: FragmentGraph -> CodeOrReference -> Either String String
+expandBlockBody1 _ (Code body) = Right body
+expandBlockBody1 fragments (Reference name) = expandBlock fragments name
+
+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
+concatMapM f lists = liftM concat $ mapM f lists