s-cargot/Data/SCargot/Repr/WellFormed.hs

{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

module Data.SCargot.Repr.WellFormed
       ( -- * 'WellFormedSExpr' representation
         R.WellFormedSExpr(..)
       , R.toWellFormed
       , R.fromWellFormed
         -- * Constructing and Deconstructing
       , cons
       , uncons
         -- * Useful pattern synonyms
       , pattern (:::)
       , pattern L
       , pattern A
       , pattern Nil
         -- * Useful processing functions
       , fromPair
       , fromList
       , fromAtom
       , asPair
       , asList
       , isAtom
       , isNil
       , asAtom
       , asAssoc
       , car
       , cdr
       ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*>), pure)
#endif
import Data.SCargot.Repr as R

-- | Produce the head and tail of the s-expression (if possible).
--
-- >>> uncons (L [A "el", A "eph", A "ant"])
-- Just (WFSAtom "el",WFSList [WFSAtom "eph",WFSAtom "ant"])
uncons :: WellFormedSExpr a -> Maybe (WellFormedSExpr a, WellFormedSExpr a)
uncons R.WFSAtom {}       = Nothing
uncons (R.WFSList [])     = Nothing
uncons (R.WFSList (x:xs)) = Just (x, R.WFSList xs)

-- | Combine the two-expressions into a new one. This will return
--   @Nothing@ if the resulting s-expression is not well-formed.
--
-- >>> cons (A "el") (L [A "eph", A "ant"])
-- Just (WFSList [WFSAtom "el",WFSAtom "eph",WFSAtom "ant"])
-- >>> cons (A "pachy") (A "derm"))
-- Nothing
cons :: WellFormedSExpr a -> WellFormedSExpr a -> Maybe (WellFormedSExpr a)
cons _ (R.WFSAtom {}) = Nothing
cons x (R.WFSList xs) = Just (R.WFSList (x:xs))

-- | A shorter infix alias to grab the head and tail of a `WFSList`. This
--   pattern is unidirectional, because it cannot be guaranteed that it
--   is used to construct well-formed s-expressions; use the function "cons"
--   instead.
--
-- >>> let sum (x ::: xs) = x + sum xs; sum Nil = 0
#if MIN_VERSION_base(4,8,0)
pattern (:::) :: WellFormedSExpr a -> WellFormedSExpr a -> WellFormedSExpr a
#endif
pattern x ::: xs <- (uncons -> Just (x, xs))

-- | A shorter alias for `WFSList`
--
-- >>> L [A "pachy", A "derm"]
-- WFSList [WFSAtom "pachy",WFSAtom "derm"]
#if MIN_VERSION_base(4,8,0)
pattern L :: [WellFormedSExpr t] -> WellFormedSExpr t
#endif
pattern L xs = R.WFSList xs

-- | A shorter alias for `WFSAtom`
--
-- >>> A "elephant"
-- WFSAtom "elephant"
#if MIN_VERSION_base(4,8,0)
pattern A :: t -> WellFormedSExpr t
#endif
pattern A a  = R.WFSAtom a

-- | A shorter alias for `WFSList` @[]@
--
-- >>> Nil
-- WFSList []
#if MIN_VERSION_base(4,8,0)
pattern Nil :: WellFormedSExpr t
#endif
pattern Nil = R.WFSList []

getShape :: WellFormedSExpr a -> String
getShape WFSAtom {}   = "atom"
getShape (WFSList []) = "empty list"
getShape (WFSList sx) = "list of length " ++ show (length sx)

-- | Utility function for parsing a pair of things.
--
-- >>> fromPair (isAtom "pachy") (asAtom return) (L [A "pachy", A "derm"])
-- Right ((), "derm")
-- >>> fromPair (isAtom "pachy") fromAtom (L [A "pachy"])
-- Left "Expected two-element list"
fromPair :: (WellFormedSExpr t -> Either String a)
         -> (WellFormedSExpr t -> Either String b)
         -> WellFormedSExpr t -> Either String (a, b)
fromPair pl pr (L [l, r]) = (,) <$> pl l <*> pr r
fromPair _  _  sx = Left ("fromPair: expected two-element list; found " ++ getShape sx)

-- | Utility function for parsing a list of things.
--
-- >>> fromList fromAtom (L [A "this", A "that", A "the-other"])
-- Right ["this","that","the-other"]
-- >>> fromList fromAtom (A "pachyderm")
-- Left "asList: expected proper list; found dotted list"
fromList :: (WellFormedSExpr t -> Either String a)
         -> WellFormedSExpr t -> Either String [a]
fromList p (L ss) = mapM p ss
fromList _ sx     = Left ("fromList: expected list; found " ++ getShape sx)

-- | Utility function for parsing a single atom
--
-- >>> fromAtom (A "elephant")
-- Right "elephant"
-- >>> fromAtom (L [A "elephant"])
-- Left "fromAtom: expected atom; found list"
fromAtom :: WellFormedSExpr t -> Either String t
fromAtom (A a) = return a
fromAtom sx    = Left ("fromAtom: expected atom; found " ++ getShape sx)

-- | Parses a two-element list using the provided function.
--
-- >>> let go (A l) (A r) = return (l ++ r); go _ _ = Left "expected atoms"
-- >>> asPair go (L [A "pachy", A "derm"])
-- Right "pachyderm"
-- >>> asPair go (L [A "elephant"])
-- Left "asPair: expected two-element list; found list of length 1"
asPair :: ((WellFormedSExpr t, WellFormedSExpr t) -> Either String a)
       -> WellFormedSExpr t -> Either String a
asPair f (L [l, r]) = f (l, r)
asPair _ sx         = Left ("asPair: expected two-element list; found " ++ getShape sx)

-- | Parse an arbitrary-length list using the provided function.
--
-- >>> let go xs = concat <$> mapM fromAtom xs
-- >>> asList go (L [A "el", A "eph", A "ant"])
-- Right "elephant"
-- >>> asList go (A "pachyderm")
-- Left "asList: expected list; found atom"
asList :: ([WellFormedSExpr t] -> Either String a)
       -> WellFormedSExpr t -> Either String a
asList f (L ls) = f ls
asList _ sx     = Left ("asList: expected list; found " ++ getShape sx)

-- | Match a given literal atom, failing otherwise.
--
-- >>> isAtom "elephant" (A "elephant")
-- Right ()
-- >>> isAtom "elephant" (L [A "elephant"])
-- Left "isAtom: expected atom; found list"
isAtom :: Eq t => t -> WellFormedSExpr t -> Either String ()
isAtom s (A s')
  | s == s'   = return ()
  | otherwise = Left "isAtom: failed to match atom"
isAtom _ sx  = Left ("isAtom: expected atom; found " ++ getShape sx)

-- | Match an empty list, failing otherwise.
--
-- >>> isNil (L [])
-- Right ()
-- >>> isNil (A "elephant")
-- Left "isNil: expected nil; found atom"
isNil :: WellFormedSExpr t -> Either String ()
isNil Nil = return ()
isNil sx  = Left ("isNil: expected nil; found " ++ getShape sx)

-- | Parse an atom using the provided function.
--
-- >>> import Data.Char (toUpper)
-- >>> asAtom (return . map toUpper) (A "elephant")
-- Right "ELEPHANT"
-- >>> asAtom (return . map toUpper) (L [])
-- Left "asAtom: expected atom; found list"
asAtom :: (t -> Either String a) -> WellFormedSExpr t -> Either String a
asAtom f (A s) = f s
asAtom _ sx    = Left ("asAtom: expected atom; found " ++ getShape sx)

-- | Parse an assoc-list using the provided function.
--
-- >>> let def (x, y) = do { a <- fromAtom x; b <- fromAtom y; return (a ++ ": " ++ b) }
-- >>> let defList xs = do { defs <- mapM def xs; return (unlines defs) }
-- >>> asAssoc defList (L [ L [A "legs", A "four"], L [ A "trunk", A "one"] ])
-- Right "legs: four\ntrunk: one\n"
-- >>> asAssoc defList (L [ L [A "legs", A "four"], L [ A "elephant"] ])
-- Left "asAssoc: expected pair; found list of length 1"
asAssoc :: ([(WellFormedSExpr t, WellFormedSExpr t)] -> Either String a)
        -> WellFormedSExpr t -> Either String a
asAssoc f (L ss) = gatherPairs ss >>= f
  where gatherPairs (L [a, b] : ts) = (:) <$> pure (a, b) <*> gatherPairs ts
        gatherPairs []              = pure []
        gatherPairs (sx:_)          = Left ("asAssoc: expected pair; found " ++ getShape sx)
asAssoc _ sx     = Left ("asAssoc: expected list; found " ++ getShape sx)

-- | Run the parser on the first element of a Haskell list of "WellFormedSExpr" values,
--   failing if the list is empty. This is useful in conjunction with the `asList`
--   function.
car :: (WellFormedSExpr t -> Either String t')
    -> [WellFormedSExpr t] -> Either String t'
car f (x:_) = f x
car _ []    = Left "car: Taking car of zero-element list"

-- | Run the parser on all but the first element of a Haskell list of "WellFormedSExpr" values,
--   failing if the list is empty. This is useful in conjunction with the `asList`
--   function.
cdr :: ([WellFormedSExpr t] -> Either String t')
    -> [WellFormedSExpr t] -> Either String t'
cdr f (_:xs) = f xs
cdr _ []     = Left "cdr: Taking cdr of zero-element list"