Trying to make a parser builder

result?

Right module_header: 
  [ header: 
    [ module: [R]
    , [ [ module: [L]
        , imported: [type: [name: X], function: y, type: [name: Zed, everything], type: [name: We, ctors: [Can, Export, Ctors]]]
        ]
      , [module: [W], imported: everything]
      ]
    ]
  , imports: 
    [ [module: [Core, TT]]
    , [module: [Core, Evaluate]]
    , [ module: [Core, Elaborate]
      , list-of-hidden: [function: tactic, function: what, function: else]
      ]
    , [module: [Core, Typecheck], list-of-opened: [function: do, function: you, function: want]]
    , [ qualified: yes
      , module: [Idris, AbsSyntaxTree]
      , list-of-hidden: 
        [ function: just
        , type: [name: Testing, ctors: [If, We, Could, Import, Ctors]]
        , function: the
        , type: [name: Parser, everything]
        ]
      , synonym: module: [I, AT1lol]
      ]
    , [module: [Idris, IdeSlave]]
    , [module: [IRTS, CodegenCommon]]
    , [module: [Util, DynamicLinker], list-of-hidden: [function: to, function: see, function: here]]
    , [module: [Paths_idris]]
    , [module: [System, Console, Haskeline]]
    , [module: [Control, Monad, State]]
    , [module: [Data, List]]
    , [module: [Data, Char]]
    , [module: [Data, Either]]
    , [module: [Debug, Trace]]
    , [module: [Util, Pretty]]
    , [module: [Util, System]]
    ]
  ]

Schema.hs

import Text.ParserCombinators.Parsec hiding (spaces, optional, many, (<|>), token)

import Control.Applicative hiding (optional)

import Data.List

mod_header = 
    Sequence
        [ header   `Called` "header"
        , includes `Called` "imports"
        ]
        `Called` "module_header"

header = 
    Sequence
        [ Token "module"

        , mod_name

        , Optional $ list_of $ Sequence
            [ Token "module"

            , mod_name

            , (Optional $ Any
                [ list_of $ Any
                    [ type_include
                    , function
                    ]

                , everything
                ])
                `Called` "imported"
            ]

        , line_break
        ]

mod_name =
    Extract gross_identifier `atLeastOneSepBy` Token "."
        `Called` "module-name"

list_of x = Token "(" `Then` (x `SepBy` Token ",") `Before` Token ")"

item `atLeastOneSepBy` delim = Lift2 cons (item, Many $ delim `Then` item)

includes =
    Many $ Sequence
        [ Token "import"

        , Optional $
            "yes" `InsteadOf` Token "qualified" `Called` "qualified"

        , mod_name

        , Optional $ Any 
            [ Whole (Token "hiding" `Then` list)
                `Called` "list-of-hidden"

            , Whole list
                `Called` "list-of-opened"
            ]
            
        , Optional $
            Token "as" `Then` mod_name `Called` "synonym"

        , line_break
        ]

  where
    list = list_of $ Any [function, type_include]

cons a (Blob (Chain    as)  pos) = 
        Blob (Chain (a:as)) pos

line_break = Token "\n" `Before` Many (Token "\n")

type_include = 
    Sequence
        [ Extract gross_identifier `Called` "name"

        , Optional $ Any 

            [ list_of (Extract gross_identifier) `Called` "ctors"

            , everything
            ]
        ]
        `Called` "type"

function = Extract identifier `Called` "function"

everything = "everything" `InsteadOf` (Token "(" `Then` Token ".." `Then` Token ")")

-- | This wrapper could be used later to complain about semantic errors
-- | the parser shouldn't know about
data Blob 
    = Blob 
        { bag        :: Bag
        , source_pos :: SourcePos
        }

-- | This is the somehow "universal" container of program structure.
data Bag
    -- | Used to "store" reserved tokens.
    = None

    | The
        { line  :: String }

    | Named 
        { name  :: String
        , value :: Blob 
        }

    | Chain
        { chain :: [Blob] }

-- | This is the definition of structure tree.
data Structure
    = Token         String         -- | Like "reserved".
    | Extract      (Parser String) -- | Lifting the parser.
    | Many          Structure


    | Optional  Structure          -- | "None" on falture.

    | Sequence [Structure]         -- | Used to produce record-like blobs.
    | Any      [Structure]

    | String `InsteadOf` Structure
    | Structure `SepBy`  Structure
    | Structure `Then`   Structure -- | Drops result of left
    | Structure `Before` Structure -- | Drops result of right
    | Structure `Called` String    -- | Assigns name inside the bag AND does (<?> second-arg)

    | Whole Structure              -- | Wraps with "try".

    | Lift2 (Blob -> Blob -> Blob) 
            (Structure, Structure)

infix  8 `InsteadOf`
infixl 7 `Then`, `Before`
infixl 6 `SepBy`
infixl 5 `Called`

main = do
    test <- readFile "test"

    writeFile "result?" $ (++ "\n") $ show $ parse (interpret mod_header) "test" test

interpret :: Structure -> Parser Blob
interpret (Token tok) = do
    token tok 
    none

interpret (Extract parser) = do
    wrap The parser

interpret (constant `InsteadOf` struct) = do
    try $ do 
        interpret struct

        wrap The $ return constant

interpret (Optional struct) = do
    optional $ interpret struct

interpret (Many        struct) = wrap Chain $ many     $     interpret struct
interpret (Sequence   structs) = wrap Chain $ sequence $ map interpret structs
interpret (item `SepBy` delim) = wrap Chain $ interpret item `sepBy` interpret delim

interpret (left `Then` right) = do
    interpret left
    interpret right

interpret (left `Before` right) = do
    result <- interpret left

    interpret right

    return result

interpret (Any structs) = foldl (<|>) (fail "") $ map (try . interpret) structs

interpret (Whole struct) = try $ interpret struct

interpret (struct `Called` name) = (wrap (Named name) $ interpret struct) <?> name

interpret (Lift2 f (left, right)) = f <$> interpret left <*> interpret right

tokenized parser =
    try (parser <* spaces)

token name = tokenized (string name) <?> "token " ++ show name

within [l, r] x = token l *> x <* token r

gross_identifier = (:) <$> oneOf ['A'..'Z'] <*> identifier_end 
identifier       = (:) <$> oneOf ['a'..'z'] <*> identifier_end

identifier_end =
    tokenized
        $ many 
        $ oneOf 
        $ [] 
            ++ ['A'.. 'Z'] 
            ++ ['a'.. 'z']
            ++ ['0'.. '9']
            ++ ['_']

optional parser = parser <|> none

spaces  = try (skipMany (char ' ')) <?> "spaces"

none = wrap (const None) $ return ()

isNone (Blob None _) = True
isNone  _            = False

wrap :: (a -> Bag) -> Parser a -> Parser Blob
wrap f = place . fmap f

place parser = do
    ctor <- parser
    pos  <- getPosition
    
    return $ Blob ctor pos

----

-- | Pretty ugly, but I had to do it fast
instance Show Blob where
    show (Blob  None              _) = "none"
    show (Blob (The   line)       _) = line
    show (Blob (Named name value) _) = name ++ ": " ++ show1 value
        where 
            show1 blob @ (Blob (Chain list) _) 
                | all simple list              = show blob
                | otherwise                    = "\n  " ++ show blob

            show1 blob
                | simple blob                  = show blob
                | otherwise                    = "\n  " ++ show blob

    show (Blob (Chain items)      _) = 
        if all simple items 

        then          "["  ++ (intercalate   ", " $ map show $ filter (not . isNone) items) ++   "]" 

        else indent $ "[ " ++ (intercalate "\n, " $ map show $ filter (not . isNone) items) ++ "\n]"


indent = intercalate "\n  " . lines

simple (Blob  None       _) = True
simple (Blob (The  line) _) = True
simple (Blob (Named n v) _) = simple v
simple (Blob (Chain xs)  _) = all simple xs && (sum $ for xs $ length . show) < 40

for = flip map

test

module R (module L (X, y, Zed(..), We(Can, Export, Ctors)), module W(..)) where

import Core.TT
import Core.Evaluate
import Core.Elaborate hiding (tactic, what, else)
import Core.Typecheck (do, you, want)

import qualified Idris.AbsSyntaxTree hiding (just, Testing(If, We, Could, Import, Ctors), the, Parser(..)) as I.AT1lol 

import Idris.IdeSlave
import IRTS.CodegenCommon
import Util.DynamicLinker hiding (to, see, here)

import Paths_idris

import System.Console.Haskeline

import Control.Monad.State

import Data.List
import Data.Char
import Data.Either

import Debug.Trace

import Util.Pretty
import Util.System