content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE TemplateHaskell #-}
  
  module Text.Heterocephalus.Parse.Control where
  
  #if MIN_VERSION_base(4,9,0)
  #else
  import Control.Applicative ((<$>), (*>), (<*), pure)
  #endif
  import Control.Monad (guard, void)
  import Control.Monad.Reader (Reader, runReaderT)
  import Data.Char (isUpper)
  import Data.Data (Data)
  import Data.Functor (($>))
  import Data.Functor.Identity (runIdentity)
  import Data.Typeable (Typeable)
  import Text.Parsec
         (Parsec, ParsecT, (<?>), (<|>), alphaNum, between, char, choice,
          eof, many, many1, manyTill, mkPT, noneOf, oneOf, option, optional,
          runParsecT, runParserT, sepBy, skipMany, spaces, string,
          try)
  import Text.Shakespeare.Base
         (Ident(Ident), Deref, parseDeref, parseVar)
  
  import Text.Hamlet.Parse
  import Text.Heterocephalus.Parse.Option
         (ParseOptions, getControlPrefix, getVariablePrefix)
  
  data Control
    = ControlForall Deref Binding
    | ControlEndForall
    | ControlIf Deref
    | ControlElse
    | ControlElseIf Deref
    | ControlEndIf
    | ControlCase Deref
    | ControlCaseOf Binding
    | ControlEndCase
    | NoControl Content
    deriving (Data, Eq, Read, Show, Typeable)
  
  data Content = ContentRaw String
               | ContentVar Deref
      deriving (Data, Eq, Read, Show, Typeable)
  
  type UserParser = ParsecT String () (Reader ParseOptions)
  
  parseLineControl :: ParseOptions -> String -> Either String [Control]
  parseLineControl opts s =
    let readerT = runParserT lineControl () "" s
        res = runIdentity $ runReaderT readerT opts
    in case res of
         Left e -> Left $ show e
         Right x -> Right x
  
  lineControl :: UserParser [Control]
  lineControl = manyTill control $ try eof >> return ()
  
  control :: UserParser Control
  control = noControlVariable <|> controlStatement <|> noControlRaw
    where
      controlStatement :: UserParser Control
      controlStatement = do
        x <- parseControlStatement
        case x of
          Left str -> return (NoControl $ ContentRaw str)
          Right ctrl -> return ctrl
  
      noControlVariable :: UserParser Control
      noControlVariable = do
        variablePrefix <- getVariablePrefix
        x <- identityToReader $ parseVar variablePrefix
        return . NoControl $
          case x of
            Left str -> ContentRaw str
            Right deref -> ContentVar deref
  
      noControlRaw :: UserParser Control
      noControlRaw = do
        controlPrefix <- getControlPrefix
        variablePrefix <- getVariablePrefix
        (NoControl . ContentRaw) <$>
          many (noneOf [controlPrefix, variablePrefix])
  
  parseControlStatement :: UserParser (Either String Control)
  parseControlStatement = do
    a <- parseControl
    optional eol
    return a
   where
    eol :: UserParser ()
    eol = void (char '\n') <|> void (string "\r\n")
  
  parseControl :: UserParser (Either String Control)
  parseControl = do
    controlPrefix <- getControlPrefix
    void $ char controlPrefix
    let escape = char '\\' $> Left [controlPrefix]
    escape <|>
      (Right <$> parseControlBetweenBrackets) <|>
      return (Left [controlPrefix])
  
  parseControlBetweenBrackets :: UserParser Control
  parseControlBetweenBrackets =
    between (char '{') (char '}') $ spaces *> parseControl' <* spaces
  
  parseControl' :: UserParser Control
  parseControl' =
    try parseForall <|> try parseEndForall <|> try parseIf <|> try parseElseIf <|>
    try parseElse <|>
    try parseEndIf <|>
    try parseCase <|>
    try parseCaseOf <|>
    try parseEndCase
    where
      parseForall :: UserParser Control
      parseForall = do
        string "forall" *> spaces
        (x, y) <- binding
        pure $ ControlForall x y
  
      parseEndForall :: UserParser Control
      parseEndForall = string "endforall" $> ControlEndForall
  
      parseIf :: UserParser Control
      parseIf =
        string "if" *> spaces *> fmap ControlIf (identityToReader parseDeref)
  
      parseElseIf :: UserParser Control
      parseElseIf =
        string "elseif" *>
        spaces *>
        fmap ControlElseIf (identityToReader parseDeref)
  
      parseElse :: UserParser Control
      parseElse = string "else" $> ControlElse
  
      parseEndIf :: UserParser Control
      parseEndIf = string "endif" $> ControlEndIf
  
      parseCase :: UserParser Control
      parseCase =
        string "case" *>
        spaces *>
        fmap ControlCase (identityToReader parseDeref)
  
      parseCaseOf :: UserParser Control
      parseCaseOf = string "of" *> spaces *> fmap ControlCaseOf identPattern
  
      parseEndCase :: UserParser Control
      parseEndCase = string "endcase" $> ControlEndCase
  
      binding :: UserParser (Deref, Binding)
      binding = do
        y <- identPattern
        spaces
        _ <- string "<-"
        spaces
        x <- identityToReader parseDeref
        _ <- spaceTabs
        return (x, y)
  
      spaceTabs :: UserParser String
      spaceTabs = many $ oneOf " \t"
  
      -- | Parse an indentifier.  This is an sequence of alphanumeric characters,
      -- or an operator.
      ident :: UserParser Ident
      ident = do
        i <- (many1 (alphaNum <|> char '_' <|> char '\'')) <|> try operator
        white
        return (Ident i) <?> "identifier"
  
      -- | Parse an operator.  An operator is a sequence of characters in
      -- 'operatorList' in between parenthesis.
      operator :: UserParser String
      operator = do
        oper <- between (char '(') (char ')') . many1 $ oneOf operatorList
        pure $ oper
  
      operatorList :: String
      operatorList = "!#$%&*+./<=>?@\\^|-~:"
  
      parens :: UserParser a -> UserParser a
      parens = between (char '(' >> white) (char ')' >> white)
  
      brackets :: UserParser a -> UserParser a
      brackets = between (char '[' >> white) (char ']' >> white)
  
      braces :: UserParser a -> UserParser a
      braces = between (char '{' >> white) (char '}' >> white)
  
      comma :: UserParser ()
      comma = char ',' >> white
  
      atsign :: UserParser ()
      atsign = char '@' >> white
  
      equals :: UserParser ()
      equals = char '=' >> white
  
      white :: UserParser ()
      white = skipMany $ char ' '
  
      wildDots :: UserParser ()
      wildDots = string ".." >> white
  
      -- | Return 'True' if 'Ident' is a variable.  Variables are defined as
      -- starting with a lowercase letter.
      isVariable :: Ident -> Bool
      isVariable (Ident (x:_)) = not (isUpper x)
      isVariable (Ident []) = error "isVariable: bad identifier"
  
      -- | Return 'True' if an 'Ident' is a constructor.  Constructors are
      -- defined as either starting with an uppercase letter, or being an
      -- operator.
      isConstructor :: Ident -> Bool
      isConstructor (Ident (x:_)) = isUpper x || elem x operatorList
      isConstructor (Ident []) = error "isConstructor: bad identifier"
  
      -- | This function tries to parse an entire pattern binding with either
      -- @'gcon' True@ or 'apat'.  For instance, in the pattern
      -- @let Foo a b = ...@, this function tries to parse @Foo a b@ with 'gcon'.
      -- In the pattern @let n = ...@, this function tries to parse @n@ with
      -- 'apat'.
      identPattern :: UserParser Binding
      identPattern = gcon True <|> apat
        where
          apat :: UserParser Binding
          apat = choice [varpat, gcon False, parens tuplepat, brackets listpat]
  
          -- | Parse a variable in a pattern.  For instance in, in a pattern like
          -- @let Just n = ...@, this function would be what is used to parse the
          -- @n@.  This function also handles aliases with @\@@.
          varpat :: UserParser Binding
          varpat = do
            v <-
              try $ do
                v <- ident
                guard (isVariable v)
                return v
            option (BindVar v) $ do
              atsign
              b <- apat
              return (BindAs v b) <?> "variable"
  
          -- | This function tries to parse an entire pattern binding.  For
          -- instance, in the pattern @let Foo a b = ...@, this function tries to
          -- parse @Foo a b@.
          --
          -- This function first tries to parse a data contructor (using
          -- 'dataConstr').  In the example above, that would be like parsing
          -- @Foo@.
          --
          -- Then, the function tries to do two different things.
          --
          -- 1. It tries to parse record syntax with 'record'.  In a pattern like
          -- @let Foo{foo1 = 3, foo2 = "hello"} = ...@, it would parse the
          -- @{foo1 = 3, foo2 = "hello"}@ part.
          --
          -- 2. If parsing the record syntax fails, it then tries to parse
          -- many normal patterns with 'apat'.  In a pattern like
          -- @let Foo a b = ...@, it would be like parsing the @a b@ part.
          --
          -- If that fails, then it just returns the original data contructor
          -- with no arguments.
          --
          -- The 'Bool' argument determines whether or not it tries to parse
          -- normal patterns in 2.  If the boolean argument is 'True', then it
          -- tries parsing normal patterns in 2.  If the boolean argument is
          -- 'False', then 2 is skipped altogether.
          gcon :: Bool -> UserParser Binding
          gcon allowArgs = do
            c <- try dataConstr
            choice
              [ record c
              , fmap (BindConstr c) (guard allowArgs >> many apat)
              , return (BindConstr c [])
              ] <?>
              "constructor"
  
          -- | Parse a possibly qualified identifier using 'ident'.
          dataConstr :: UserParser DataConstr
          dataConstr = do
            p <- dcPiece
            ps <- many dcPieces
            return $ toDataConstr p ps
  
          dcPiece :: UserParser String
          dcPiece = do
            x@(Ident y) <- ident
            guard $ isConstructor x
            return y
  
          dcPieces :: UserParser String
          dcPieces = do
            _ <- char '.'
            dcPiece
  
          toDataConstr :: String -> [String] -> DataConstr
          toDataConstr x [] = DCUnqualified $ Ident x
          toDataConstr x (y:ys) = go (x :) y ys
            where
              go :: ([String] -> [String]) -> String -> [String] -> DataConstr
              go front next [] = DCQualified (Module $ front []) (Ident next)
              go front next (rest:rests) = go (front . (next :)) rest rests
  
          record :: DataConstr -> UserParser Binding
          record c =
            braces $ do
              (fields, wild) <- option ([], False) go
              return (BindRecord c fields wild)
            where
              go :: UserParser ([(Ident, Binding)], Bool)
              go =
                (wildDots >> return ([], True)) <|>
                (do x <- recordField
                    (xs, wild) <- option ([], False) (comma >> go)
                    return (x : xs, wild))
  
          recordField :: UserParser (Ident, Binding)
          recordField = do
            field <- ident
            p <-
              option
                (BindVar field) -- support punning
                (equals >> identPattern)
            return (field, p)
  
          tuplepat :: UserParser Binding
          tuplepat = do
            xs <- identPattern `sepBy` comma
            return $
              case xs of
                [x] -> x
                _ -> BindTuple xs
  
          listpat :: UserParser Binding
          listpat = BindList <$> identPattern `sepBy` comma
  
  identityToReader :: Parsec String () a -> UserParser a
  identityToReader p =
    mkPT $ pure . fmap (pure . runIdentity) . runIdentity . runParsecT p
  