{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module SJW.Module.Imports (
      Reference(..)
    , Tree(..)
    , parser
    , recurse
  ) where

import SJW.Source (Path(..))
import Control.Applicative ((<|>), many, optional)
import Data.Attoparsec.Text (
    Parser, char, count, digit, inClass, letter, sepBy, string, takeWhile
  )
import Data.Map (Map, foldlWithKey)
import qualified Data.Map as Map (empty, insert, lookup)
import qualified Data.Text as Text (pack)
import Prelude hiding (takeWhile)

data Reference =
    ModulePath {Reference -> Path
modulePath :: Path}
  | Object {modulePath :: Path, Reference -> String
field :: String}
  deriving Int -> Reference -> ShowS
[Reference] -> ShowS
Reference -> String
(Int -> Reference -> ShowS)
-> (Reference -> String)
-> ([Reference] -> ShowS)
-> Show Reference
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Reference] -> ShowS
$cshowList :: [Reference] -> ShowS
show :: Reference -> String
$cshow :: Reference -> String
showsPrec :: Int -> Reference -> ShowS
$cshowsPrec :: Int -> Reference -> ShowS
Show

data Tree = Tree {
      Tree -> Maybe Reference
target :: Maybe Reference
    , Tree -> Map String Tree
children :: Map String Tree
  } deriving Int -> Tree -> ShowS
[Tree] -> ShowS
Tree -> String
(Int -> Tree -> ShowS)
-> (Tree -> String) -> ([Tree] -> ShowS) -> Show Tree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tree] -> ShowS
$cshowList :: [Tree] -> ShowS
show :: Tree -> String
$cshow :: Tree -> String
showsPrec :: Int -> Tree -> ShowS
$cshowsPrec :: Int -> Tree -> ShowS
Show

data Mapping = Mapping {
      Mapping -> Path
exposedName :: Path
    , Mapping -> Reference
reference :: Reference
  }

recurse :: (a -> [String] -> Reference -> a) -> a -> Tree -> a
recurse :: (a -> [String] -> Reference -> a) -> a -> Tree -> a
recurse a -> [String] -> Reference -> a
f a
initValue = [String] -> a -> Tree -> a
recAux [] a
initValue
  where
    next :: [String] -> a -> Maybe Reference -> a
next [String]
_ a
value Maybe Reference
Nothing = a
value
    next [String]
stack a
value (Just Reference
ref) = a -> [String] -> Reference -> a
f a
value ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
stack) Reference
ref
    recAux :: [String] -> a -> Tree -> a
recAux [String]
stack a
value Tree
tree =
      let nextValue :: a
nextValue = [String] -> a -> Maybe Reference -> a
next [String]
stack a
value (Tree -> Maybe Reference
target Tree
tree) in
      (a -> String -> Tree -> a) -> a -> Map String Tree -> a
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
foldlWithKey (\a
a String
k Tree
b -> [String] -> a -> Tree -> a
recAux (String
kString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
stack) a
a Tree
b) a
nextValue (Tree -> Map String Tree
children Tree
tree)

space :: Parser ()
space :: Parser ()
space = (Char -> Bool) -> Parser Text
takeWhile (String -> Char -> Bool
inClass String
" \t\r\n") Parser Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

between :: Parser a -> (Parser b, Parser c) -> Parser a
between :: Parser a -> (Parser b, Parser c) -> Parser a
between Parser a
p (Parser b
left, Parser c
right) = Parser b
left Parser b -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
space Parser () -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
space Parser a -> Parser c -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser c
right

keyword :: String -> Parser ()
keyword :: String -> Parser ()
keyword String
k = Parser ()
space Parser () -> Parser Text -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
string (String -> Text
Text.pack String
k) Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
space

name :: Parser String
name :: Parser String
name = (:) (Char -> ShowS) -> Parser Text Char -> Parser Text ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Char
letter Parser Text ShowS -> Parser String -> Parser String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Char -> Parser String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Text Char
letter Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Char
digit)

aliasedName :: Parser (Maybe String, String)
aliasedName :: Parser (Maybe String, String)
aliasedName =
    ((,) (Maybe String -> String -> (Maybe String, String))
-> Parser Text (Maybe String)
-> Parser Text (String -> (Maybe String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> Parser String -> Parser Text (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
name) Parser Text (String -> (Maybe String, String))
-> Parser () -> Parser Text (String -> (Maybe String, String))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser ()
keyword String
"as" Parser Text (String -> (Maybe String, String))
-> Parser String -> Parser (Maybe String, String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String
name)
  Parser (Maybe String, String)
-> Parser (Maybe String, String) -> Parser (Maybe String, String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((\String
s -> (String -> Maybe String
forall a. a -> Maybe a
Just String
s, String
s)) (String -> (Maybe String, String))
-> Parser String -> Parser (Maybe String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
name)

buildMappings :: Maybe [(Maybe String, String)] -> Path -> [Mapping]
buildMappings :: Maybe [(Maybe String, String)] -> Path -> [Mapping]
buildMappings Maybe [(Maybe String, String)]
Nothing Path
modulePath =
  [Path -> Reference -> Mapping
Mapping Path
modulePath (Path -> Reference
ModulePath Path
modulePath)]
buildMappings (Just [(Maybe String, String)]
nameAssocs) Path
modulePath = (Maybe String, String) -> Mapping
mappingOf ((Maybe String, String) -> Mapping)
-> [(Maybe String, String)] -> [Mapping]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe String, String)]
nameAssocs
  where
    mappingOf :: (Maybe String, String) -> Mapping
mappingOf (Maybe String
Nothing, String
dest) = Path -> Reference -> Mapping
Mapping ([String] -> Path
Path [String
dest]) (Path -> Reference
ModulePath Path
modulePath)
    mappingOf (Just String
source, String
dest) =
      Path -> Reference -> Mapping
Mapping ([String] -> Path
Path [String
dest]) (Path -> String -> Reference
Object Path
modulePath String
source)

mappingParser :: Parser [Mapping]
mappingParser :: Parser [Mapping]
mappingParser =
  Maybe [(Maybe String, String)] -> Path -> [Mapping]
buildMappings (Maybe [(Maybe String, String)] -> Path -> [Mapping])
-> Parser Text (Maybe [(Maybe String, String)])
-> Parser Text (Path -> [Mapping])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text [(Maybe String, String)]
-> Parser Text (Maybe [(Maybe String, String)])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text [(Maybe String, String)]
fromClause Parser Text (Path -> [Mapping])
-> Parser Text Path -> Parser [Mapping]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([String] -> Path
Path ([String] -> Path) -> Parser Text [String] -> Parser Text Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
name Parser String -> Parser Text Char -> Parser Text [String]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser Text Char
char Char
'.')
  where
    fromClause :: Parser Text [(Maybe String, String)]
fromClause =
      (Int
-> Parser (Maybe String, String)
-> Parser Text [(Maybe String, String)]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
1 (Parser (Maybe String, String)
aliasedName Parser (Maybe String, String)
-> Parser (Maybe String, String) -> Parser (Maybe String, String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Maybe String, String)
forall a. Parser Text (Maybe a, String)
star) Parser Text [(Maybe String, String)]
-> Parser Text [(Maybe String, String)]
-> Parser Text [(Maybe String, String)]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text [(Maybe String, String)]
namesBlock) Parser Text [(Maybe String, String)]
-> Parser () -> Parser Text [(Maybe String, String)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser ()
keyword String
"from"
    namesBlock :: Parser Text [(Maybe String, String)]
namesBlock =
      (Parser (Maybe String, String)
aliasedName Parser (Maybe String, String)
-> Parser () -> Parser Text [(Maybe String, String)]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` (Char -> Parser Text Char
char Char
',' Parser Text Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
space)) Parser Text [(Maybe String, String)]
-> (Parser Text Char, Parser Text Char)
-> Parser Text [(Maybe String, String)]
forall a b c. Parser a -> (Parser b, Parser c) -> Parser a
`between` (Char -> Parser Text Char
char Char
'{', Char -> Parser Text Char
char Char
'}')
    star :: Parser Text (Maybe a, String)
star = (,) (Maybe a -> String -> (Maybe a, String))
-> Parser Text (Maybe a)
-> Parser Text (String -> (Maybe a, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Text Char
char Char
'*' Parser Text Char -> Parser Text (Maybe a) -> Parser Text (Maybe a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe a -> Parser Text (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing) Parser Text (String -> (Maybe a, String))
-> Parser () -> Parser Text (String -> (Maybe a, String))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser ()
keyword String
"as" Parser Text (String -> (Maybe a, String))
-> Parser String -> Parser Text (Maybe a, String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String
name

emptyTree :: Tree
emptyTree :: Tree
emptyTree = Tree :: Maybe Reference -> Map String Tree -> Tree
Tree {
      target :: Maybe Reference
target = Maybe Reference
forall a. Maybe a
Nothing
    , children :: Map String Tree
children = Map String Tree
forall k a. Map k a
Map.empty
  }

insertMapping :: Tree -> Mapping -> Tree
insertMapping :: Tree -> Mapping -> Tree
insertMapping Tree
tmpTree (Mapping {Path
exposedName :: Path
exposedName :: Mapping -> Path
exposedName, Reference
reference :: Reference
reference :: Mapping -> Reference
reference}) =
  [String] -> Tree -> Tree
insertAt [String]
components Tree
tmpTree
  where
    Path [String]
components = Path
exposedName
    insertAt :: [String] -> Tree -> Tree
insertAt [] Tree
tree = Tree
tree {target :: Maybe Reference
target = Reference -> Maybe Reference
forall a. a -> Maybe a
Just Reference
reference}
    insertAt (String
next:[String]
restOfPath) tree :: Tree
tree@(Tree {Map String Tree
children :: Map String Tree
children :: Tree -> Map String Tree
children}) =
      let subTree :: Tree
subTree = Tree -> (Tree -> Tree) -> Maybe Tree -> Tree
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Tree
emptyTree Tree -> Tree
forall a. a -> a
id (Maybe Tree -> Tree) -> Maybe Tree -> Tree
forall a b. (a -> b) -> a -> b
$ String -> Map String Tree -> Maybe Tree
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
next Map String Tree
children in Tree
tree {
        children :: Map String Tree
children = String -> Tree -> Map String Tree -> Map String Tree
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
next ([String] -> Tree -> Tree
insertAt [String]
restOfPath Tree
subTree) Map String Tree
children
      }

parser :: Parser Tree
parser :: Parser Tree
parser = (Tree -> [Mapping] -> Tree) -> Tree -> [[Mapping]] -> Tree
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Tree -> Mapping -> Tree) -> Tree -> [Mapping] -> Tree
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Tree -> Mapping -> Tree
insertMapping) Tree
emptyTree ([[Mapping]] -> Tree) -> Parser Text [[Mapping]] -> Parser Tree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Mapping]
importParser Parser [Mapping] -> Parser Text -> Parser Text [[Mapping]]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Parser Text
blank
  where
    blank :: Parser Text
blank = (Char -> Bool) -> Parser Text
takeWhile (String -> Char -> Bool
inClass String
" \t\r\n")
    importParser :: Parser [Mapping]
importParser = Parser [Mapping]
mappingParser Parser [Mapping]
-> (Parser Text, Parser Text Char) -> Parser [Mapping]
forall a b c. Parser a -> (Parser b, Parser c) -> Parser a
`between` (Text -> Parser Text
string Text
"import", Char -> Parser Text Char
char Char
';')