diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Fragment.hs | 17 | ||||
| -rw-r--r-- | src/Main.hs | 1 | ||||
| -rw-r--r-- | src/Tangle.hs | 38 |
3 files changed, 25 insertions, 31 deletions
diff --git a/src/Fragment.hs b/src/Fragment.hs index 14172da..6850662 100644 --- a/src/Fragment.hs +++ b/src/Fragment.hs @@ -12,11 +12,8 @@ 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 +module Fragment ( Fragment(..) , CodeOrReference(..) - , isBlockCode - , blockName, blockContents , parseStdin , parseFile) where @@ -34,18 +31,6 @@ 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 74ea1d2..bf81ae2 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -19,6 +19,7 @@ import System.Exit (exitFailure) import Fragment (parseFile, parseStdin) import Tangle (tangle) +import Weave (weave) main :: IO () main = do diff --git a/src/Tangle.hs b/src/Tangle.hs index 049c497..edfd6ed 100644 --- a/src/Tangle.hs +++ b/src/Tangle.hs @@ -12,6 +12,7 @@ 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 Tangle (tangle) where import Control.Exception (assert) @@ -19,8 +20,7 @@ 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)) +import Fragment (Fragment(..), CodeOrReference(..)) type FragmentGraph = Map String [CodeOrReference] @@ -28,24 +28,32 @@ tangle :: [Fragment] -> Either String String tangle fragments = case filter isBlockCode fragments of [] -> Right "" - codeBlocks@(root:_) -> - expandBlock (fragmentGraph codeBlocks) (blockName root) + blockCodeFragments@((BlockCode rootName _):_) -> + expandBlockCodeFragment (fragmentGraph blockCodeFragments) rootName + (Documentation {..}):_ -> error "isBlockCode did not work correctly" 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 = +fragmentGraph = + Map.fromListWith (++) . + map (\block -> blockToPair $ assert (isBlockCode block) block) + where blockToPair (BlockCode name body) = (name, body) + blockToPair (Documentation {..}) = + error "Documentation fragments cannot be converted to pairs" + +expandBlockCodeFragment :: FragmentGraph -> String -> Either String String +expandBlockCodeFragment fragments name = case Map.lookup name fragments of Nothing -> Left $ "Desired node " ++ name ++ " not in fragment graph" - Just block -> concatMapM (expandBlockBody1 fragments) block + Just block -> concatMapM (expandBlockCodeBody fragments) block + +expandBlockCodeBody :: FragmentGraph -> CodeOrReference -> Either String String +expandBlockCodeBody _ (Code body) = Right body +expandBlockCodeBody fragments (Reference name) = + expandBlockCodeFragment fragments name -expandBlockBody1 :: FragmentGraph -> CodeOrReference -> Either String String -expandBlockBody1 _ (Code body) = Right body -expandBlockBody1 fragments (Reference name) = expandBlock fragments name +isBlockCode :: Fragment -> Bool +isBlockCode (Documentation {..}) = False +isBlockCode (BlockCode {..}) = True concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f lists = liftM concat $ mapM f lists |