Sourcemap.hs

{-# LANGUAGE TemplateHaskell #-}

module Axel.Sourcemap where

import Axel.Prelude

import Axel.Eff.Lens (assign, modifying)
import Axel.Eff.Loop (breakLoop)
import qualified Axel.Eff.Loop as Effs (runLoop)
import qualified Axel.Parse.AST as Parse
  ( Expression(LiteralInt, LiteralString, SExpression, Symbol)
  , quoteExpression
  )
import Axel.Utils.List (unsafeHead)
import Axel.Utils.Text (Renderer)
import Axel.Utils.Tuple (Annotated, annotate, annotation, unannotate)

import Control.Lens ((|>))
import Control.Lens.Operators ((^.))
import Control.Lens.TH (makeFieldsNoPrefix, makeWrapped)
import Control.Monad (when)

import Data.Data (Data)
import Data.Foldable (for_)
import Data.Hashable (Hashable)
import Data.Map (Map)
import Data.MonoTraversable (oconcatMap, ofor_)
import qualified Data.Text as T

import qualified Effectful as Eff
import qualified Effectful.State.Static.Local as Eff

import GHC.Generics (Generic)

data Position =
  Position
    { _line :: Int
    , _column :: Int
    }
  deriving (Data, Eq, Generic, Show)

makeFieldsNoPrefix ''Position

instance Hashable Position

-- NOTE We're using `String` instead of `FilePath` so that we don't have to rely
-- on `Axel.Prelude` or `-XOverloadedStrings` in user-facing code.
type SourcePosition = (String, Position)

renderSourcePosition :: Renderer SourcePosition
renderSourcePosition (filePath, position) =
  let filePath' =
        if filePath == ""
          then "<unknown>"
          else T.pack filePath
   in filePath' <>
      ":" <> showText (position ^. line) <> ":" <> showText (position ^. column)

type SourceMetadata = Maybe SourcePosition

newtype Output =
  Output [Annotated SourceMetadata Text]
  deriving (Eq, Show)

deriving instance Semigroup Output

deriving instance Monoid Output

makeWrapped ''Output

raw :: Output -> Text
raw (Output output) = oconcatMap unannotate output

unassociated :: Text -> Output
unassociated x = Output [annotate Nothing x]

type Expression = Parse.Expression SourceMetadata

isCompoundExpressionWrapperHead :: Expression -> Bool
isCompoundExpressionWrapperHead (Parse.Symbol _ "begin") = True
isCompoundExpressionWrapperHead _ = False

wrapCompoundExpressions :: [Expression] -> Expression
wrapCompoundExpressions stmts =
  Parse.SExpression Nothing (Parse.Symbol Nothing "begin" : stmts)

unwrapCompoundExpressions :: Expression -> [Expression]
unwrapCompoundExpressions (Parse.SExpression _ (Parse.Symbol _ "begin":stmts)) =
  stmts
unwrapCompoundExpressions _ =
  error "unwrapCompoundExpressions must be passed a top-level program!"

data Bracket
  = CurlyBraces
  | DoubleQuotes
  | Parentheses
  | SingleQuotes
  | SquareBrackets

openBracket :: Bracket -> Char
openBracket CurlyBraces = '{'
openBracket DoubleQuotes = '"'
openBracket Parentheses = '('
openBracket SingleQuotes = '\''
openBracket SquareBrackets = '['

closeBracket :: Bracket -> Char
closeBracket CurlyBraces = '}'
closeBracket DoubleQuotes = '"'
closeBracket Parentheses = ')'
closeBracket SingleQuotes = '\''
closeBracket SquareBrackets = ']'

tryRemoveBrackets :: Bracket -> Text -> Text
tryRemoveBrackets bracket text =
  if T.length text >= 2 &&
     T.head text == openBracket bracket && T.last text == closeBracket bracket
    then T.init $ T.tail text
    else text

surround :: Bracket -> Output -> Output
surround bracket x =
  let (startMetadata, endMetadata) =
        case x of
          Output [] -> (Nothing, Nothing)
          Output xs -> (unsafeHead xs ^. annotation, last xs ^. annotation)
   in Output [annotate startMetadata (T.singleton $ openBracket bracket)] <>
      x <> Output [annotate endMetadata (T.singleton $ closeBracket bracket)]

data Delimiter
  = Commas
  | Newlines
  | Pipes
  | Semicolons
  | Spaces

delimit :: Delimiter -> [Output] -> Output
delimit delimiter =
  Output .
  tryInit . -- Remove unneeded final delimiter
  concatMap
    (\(Output x) ->
       let metadata =
             case x of
               [] -> Nothing
               (x':_) -> x' ^. annotation
        in x |> annotate metadata (renderDelimiter delimiter))
  where
    tryInit :: [a] -> [a]
    tryInit [] = []
    tryInit xs = init xs
    renderDelimiter :: Delimiter -> Text
    renderDelimiter Commas = ","
    renderDelimiter Newlines = "\n"
    renderDelimiter Pipes = "|"
    renderDelimiter Semicolons = ";"
    renderDelimiter Spaces = " "

renderBlock :: [Output] -> Output
renderBlock = surround CurlyBraces . delimit Semicolons

-- | Given a position in some transpiled output, find the corresponding
--   metadata in the original source.
--   Behavior is undefined if `column transPos == 0`.
--
--   TODO Make algorithm functional (assuming this can be cleanly done so).
findOriginalPosition ::
     forall ann. [Annotated ann Text] -> Position -> Maybe ann
findOriginalPosition output transPos =
  Eff.runPureEff $
  Eff.evalState (Position {_line = 1, _column = 0}) $
  Effs.runLoop $ do
    for_ output $ \chunk ->
      ofor_ (unannotate chunk) $ \char -> do
        if char == '\n'
          then do
            assign @Position column 0
            modifying @Position line succ
          else modifying @Position column succ
        Eff.get >>= \newSrcPos ->
          when (newSrcPos == transPos) $ breakLoop (Just $ chunk ^. annotation)
    pure Nothing

-- TODO Derive this with Template Haskell (it's currently very brittle)
quoteString :: String -> Expression
quoteString = Parse.LiteralString Nothing

-- TODO Derive this with Template Haskell (it's currently very brittle)
quotePosition :: Position -> Expression
quotePosition sourcePosition =
  Parse.SExpression
    Nothing
    [ Parse.Symbol Nothing "AxelRuntime_Sourcemap.Position"
    , Parse.LiteralInt Nothing (sourcePosition ^. line)
    , Parse.LiteralInt Nothing (sourcePosition ^. column)
    ]

-- TODO Derive this with Template Haskell (it's currently very brittle)
quote2Tuple :: (a -> Expression, b -> Expression) -> (a, b) -> Expression
quote2Tuple (quoterA, quoterB) (a, b) =
  Parse.SExpression Nothing [Parse.Symbol Nothing ",", quoterA a, quoterB b]

-- TODO Derive this with Template Haskell (it's currently very brittle)
quoteMaybe :: (a -> Expression) -> Maybe a -> Expression
quoteMaybe _ Nothing = Parse.Symbol Nothing "AxelRuntime_GHCPrelude.Nothing"
quoteMaybe quoter (Just x) =
  Parse.SExpression
    Nothing
    [Parse.Symbol Nothing "AxelRuntime_GHCPrelude.Just", quoter x]

quoteSourceMetadata :: Maybe SourcePosition -> Expression
quoteSourceMetadata = quoteMaybe $ quote2Tuple (quoteString, quotePosition)

quoteSMExpression :: Expression -> Expression
quoteSMExpression = Parse.quoteExpression quoteSourceMetadata

-- | Keys are the module file paths, and values are (the module name, the transpiled output).
type ModuleInfo = Map FilePath (Text, Maybe Output)