Loupe.hs

{-# LANGUAGE LambdaCase #-}

module Loupe
  ( analyze
  , analyze'
  , analyzeMay
  ) where

import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Syntax

analyzeMay :: String -> Maybe String
analyzeMay = either (const Nothing) Just . analyze

analyze' :: String -> String
analyze' = either id id . analyze

analyze :: String -> Either String String
analyze s = case parse (prepare s) of
  ParseFailed srcLoc errMsg -> Left $ renderError srcLoc errMsg
  ParseOk result -> case result :: Module SrcSpanInfo of
    XmlPage   {} -> Left "Expected Module but got XmlPage."
    XmlHybrid {} -> Left "Expected Module but got XmlHybrid."
    Module _ _ _ _ (decl:_) -> case decl of
      TypeSig _ _ type' -> handleTypeSig (unitize type')
      other -> Left $ "Expected typeSig, got: " ++ show other
    other -> error $ "Handling not implemented for: " ++ show other

unitize :: Functor f => f a -> f ()
unitize = fmap . const $ ()

handleTypeSig :: Show a => Type a -> Either String String
handleTypeSig type' = error "do something with type' here"

prepare :: String -> String
prepare typeSig = unlines
  [ "module LoupeSpace where"
  , "x :: " ++ typeSig
  , "x = undefined"
  ]

renderError :: SrcLoc -> String -> String
renderError _srcLoc errMsg = "renderError not fully impl:"  ++ errMsg