Skip to main content
edited tags; edited title
Link
200_success
  • 144.2k
  • 22
  • 188
  • 473

Parsing DAG from text in Haskell

Source Link
sevo
  • 291
  • 2
  • 6

Parsing DAG from text in Haskell

This module allows to parse indented text file into Map from node to child nodes identified by Coordinate. This module seems way too complex - mainly because of managing stack that allows to "jump back" with decreasing indentation. How can I redesign it?

sample input:

a
 b
 c
  d
   e
 f

produces:

*Parse> parse tree
fromList [("a",["f","c","b"]),("c",["d"]),("d",["e"])]

implementation:

module Parse where
import System.Environment (getArgs)
import Data.List (find, isInfixOf, intercalate)
import Data.Char (isAlpha)
import Control.Lens ((&))
import Data.List.Split (splitWhen)
import Control.Arrow
import qualified Data.Map.Strict as Map
import Data.Maybe
import Debug.Trace
import Control.Applicative

type Coordinate = String

parse :: String -> Map.Map Coordinate [Coordinate]
parse = snd . go
  where
    go = foldl addDependency ([], Map.empty) . filter ((>0) . length) . lines

addDependency (stack, acc) line = if null stack then
                                   (,) [(0, line)] $ Map.singleton line []
                                   else let children = fromMaybe [] . flip Map.lookup acc
                                            lineDepth = countIndent line
                                            indent = signum $ lineDepth - (fst . head $ stack)
                                            coord = toCoordinate line
                                            addChild c = Map.insert c (coord : children c) acc
                                            parent = tail stack
                                        in
                                         case indent of
                                           0 -> (,) ((lineDepth,coord):parent) $ addChild (snd . head $ parent)
                                           1 -> (,) ((lineDepth,coord):stack) (addChild $ snd . head $ stack)
                                           _ -> let newStack = back stack lineDepth
                                                    newHead = snd . head $ newStack
                                                     in (,) ((lineDepth,coord):newStack) (addChild newHead)

back stack@((i,c):ss) indent = if indent > i then stack else back ss indent
toCoordinate = dropWhile (not . special)
special = (||) <$> isAlpha <*> (=='(')
countIndent = length . takeWhile (not . special)